packages feed

cabal-install-bundle (empty) → 0.10.2

raw patch · 188 files changed

+50067/−0 lines, 188 filesdep +Cabaldep +arraydep +basesetup-changed

Dependencies added: Cabal, array, base, bytestring, containers, directory, filepath, old-time, pretty, process, time, unix

Files

+ Codec/Compression/GZip.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (c) 2006-2008 Duncan Coutts+-- License     :  BSD-style+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable (H98 + FFI)+--+-- Compression and decompression of data streams in the gzip format.+--+-- The format is described in detail in RFC #1952:+-- <http://www.ietf.org/rfc/rfc1952.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.GZip (++  -- | This module provides pure functions for compressing and decompressing+  -- streams of data in the gzip format and represented by lazy 'ByteString's.+  -- This makes it easy to use either in memory or with disk or network IO.+  --+  -- For example a simple gzip compression program is just:+  --+  -- > import qualified Data.ByteString.Lazy as ByteString+  -- > import qualified Codec.Compression.GZip as GZip+  -- >+  -- > main = ByteString.interact GZip.compress+  --+  -- Or you could lazily read in and decompress a @.gz@ file using:+  --+  -- > content <- fmap GZip.decompress (readFile file)+  --++  -- * Simple compression and decompression+  compress,+  decompress,++  -- * Extended api with control over compression parameters+  compressWith,+  decompressWith,++  CompressParams(..), defaultCompressParams,+  DecompressParams(..), defaultDecompressParams,++  -- ** The compression parameter types+  CompressionLevel(..),+    defaultCompression,+    noCompression,+    bestSpeed,+    bestCompression,+    compressionLevel,+  Method(..),+    deflateMethod,+  WindowBits(..),+    defaultWindowBits,+    windowBits,+  MemoryLevel(..),+    defaultMemoryLevel,+    minMemoryLevel,+    maxMemoryLevel,+    memoryLevel,+  CompressionStrategy(..),+    defaultStrategy,+    filteredStrategy,+    huffmanOnlyStrategy,++  ) where++import Data.ByteString.Lazy (ByteString)++import qualified Codec.Compression.Zlib.Internal as Internal+import Codec.Compression.Zlib.Internal hiding (compress, decompress)+++-- | Decompress a stream of data in the gzip format.+--+-- There are a number of errors that can occur. In each case an exception will+-- be thrown. The possible error conditions are:+--+-- * if the stream does not start with a valid gzip header+--+-- * if the compressed stream is corrupted+--+-- * if the compressed stream ends permaturely+--+-- Note that the decompression is performed /lazily/. Errors in the data stream+-- may not be detected until the end of the stream is demanded (since it is+-- only at the end that the final checksum can be checked). If this is+-- important to you, you must make sure to consume the whole decompressed+-- stream before doing any IO action that depends on it.+--+decompress :: ByteString -> ByteString+decompress = decompressWith defaultDecompressParams+++-- | Like 'decompress' but with the ability to specify various decompression+-- parameters. Typical usage:+--+-- > decompressWith defaultCompressParams { ... }+--+decompressWith :: DecompressParams -> ByteString -> ByteString+decompressWith = Internal.decompress gzipFormat+++-- | Compress a stream of data into the gzip format.+--+-- This uses the default compression parameters. In partiular it uses the+-- default compression level which favours a higher compression ratio over+-- compression speed, though it does not use the maximum compression level.+--+-- Use 'compressWith' to adjust the compression level or other compression+-- parameters.+--+compress :: ByteString -> ByteString+compress = compressWith defaultCompressParams+++-- | Like 'compress' but with the ability to specify various compression+-- parameters. Typical usage:+--+-- > compressWith defaultCompressParams { ... }+--+-- In particular you can set the compression level:+--+-- > compressWith defaultCompressParams { compressLevel = BestCompression }+--+compressWith :: CompressParams -> ByteString -> ByteString+compressWith = Internal.compress gzipFormat
+ Codec/Compression/Zlib.hs view
@@ -0,0 +1,118 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (c) 2006-2008 Duncan Coutts+-- License     :  BSD-style+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable (H98 + FFI)+--+-- Compression and decompression of data streams in the zlib format.+--+-- The format is described in detail in RFC #1950:+-- <http://www.ietf.org/rfc/rfc1950.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib (++  -- | This module provides pure functions for compressing and decompressing+  -- streams of data in the zlib format and represented by lazy 'ByteString's.+  -- This makes it easy to use either in memory or with disk or network IO.++  -- * Simple compression and decompression+  compress,+  decompress,++  -- * Extended api with control over compression parameters+  compressWith,+  decompressWith,++  CompressParams(..), defaultCompressParams,+  DecompressParams(..), defaultDecompressParams,++  -- ** The compression parameter types+  CompressionLevel(..),+    defaultCompression,+    noCompression,+    bestSpeed,+    bestCompression,+    compressionLevel,+  Method(..),+    deflateMethod,+  WindowBits(..),+    defaultWindowBits,+    windowBits,+  MemoryLevel(..),+    defaultMemoryLevel,+    minMemoryLevel,+    maxMemoryLevel,+    memoryLevel,+  CompressionStrategy(..),+    defaultStrategy,+    filteredStrategy,+    huffmanOnlyStrategy,++  ) where++import Data.ByteString.Lazy (ByteString)++import qualified Codec.Compression.Zlib.Internal as Internal+import Codec.Compression.Zlib.Internal hiding (compress, decompress)+++-- | Decompress a stream of data in the zlib format.+--+-- There are a number of errors that can occur. In each case an exception will+-- be thrown. The possible error conditions are:+--+-- * if the stream does not start with a valid gzip header+--+-- * if the compressed stream is corrupted+--+-- * if the compressed stream ends permaturely+--+-- Note that the decompression is performed /lazily/. Errors in the data stream+-- may not be detected until the end of the stream is demanded (since it is+-- only at the end that the final checksum can be checked). If this is+-- important to you, you must make sure to consume the whole decompressed+-- stream before doing any IO action that depends on it.+--+decompress :: ByteString -> ByteString+decompress = decompressWith defaultDecompressParams+++-- | Like 'decompress' but with the ability to specify various decompression+-- parameters. Typical usage:+--+-- > decompressWith defaultCompressParams { ... }+--+decompressWith :: DecompressParams -> ByteString -> ByteString+decompressWith = Internal.decompress zlibFormat+++-- | Compress a stream of data into the zlib format.+--+-- This uses the default compression parameters. In partiular it uses the+-- default compression level which favours a higher compression ratio over+-- compression speed, though it does not use the maximum compression level.+--+-- Use 'compressWith' to adjust the compression level or other compression+-- parameters.+--+compress :: ByteString -> ByteString+compress = compressWith defaultCompressParams+++-- | Like 'compress' but with the ability to specify various compression+-- parameters. Typical usage:+--+-- > compressWith defaultCompressParams { ... }+--+-- In particular you can set the compression level:+--+-- > compressWith defaultCompressParams { compressLevel = BestCompression }+--+compressWith :: CompressParams -> ByteString -> ByteString+compressWith = Internal.compress zlibFormat
+ Codec/Compression/Zlib/Internal.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (c) 2006-2008 Duncan Coutts+-- License     :  BSD-style+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable (H98 + FFI)+--+-- Pure stream based interface to lower level zlib wrapper+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Internal (++  -- * Compression+  compress,+  CompressParams(..),+  defaultCompressParams,++  -- * Decompression+  decompress,+  DecompressParams(..),+  defaultDecompressParams,++  -- * The compression parameter types+  Stream.Format(..),+    Stream.gzipFormat,+    Stream.zlibFormat,+    Stream.rawFormat,+    Stream.gzipOrZlibFormat,+  Stream.CompressionLevel(..),+    Stream.defaultCompression,+    Stream.noCompression,+    Stream.bestSpeed,+    Stream.bestCompression,+    Stream.compressionLevel,+  Stream.Method(..),+    Stream.deflateMethod,+  Stream.WindowBits(..),+    Stream.defaultWindowBits,+    Stream.windowBits,+  Stream.MemoryLevel(..),+    Stream.defaultMemoryLevel,+    Stream.minMemoryLevel,+    Stream.maxMemoryLevel,+    Stream.memoryLevel,+  Stream.CompressionStrategy(..),+    Stream.defaultStrategy,+    Stream.filteredStrategy,+    Stream.huffmanOnlyStrategy,++  -- * Low-level API to get explicit error reports+  decompressWithErrors,+  DecompressStream(..),+  DecompressError(..),+  foldDecompressStream,+  fromDecompressStream,+  ) where++import Prelude hiding (length)+import Control.Monad (when)+import Control.Exception (assert)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Internal as S++import qualified Codec.Compression.Zlib.Stream as Stream+import Codec.Compression.Zlib.Stream (Stream)++-- | The full set of parameters for compression. The defaults are+-- 'defaultCompressParams'.+--+-- The 'compressBufferSize' is the size of the first output buffer containing+-- the compressed data. If you know an approximate upper bound on the size of+-- the compressed data then setting this parameter can save memory. The default+-- compression output buffer size is @16k@. If your extimate is wrong it does+-- not matter too much, the default buffer size will be used for the remaining+-- chunks.+--+data CompressParams = CompressParams {+  compressLevel       :: !Stream.CompressionLevel,+  compressMethod      :: !Stream.Method,+  compressWindowBits  :: !Stream.WindowBits,+  compressMemoryLevel :: !Stream.MemoryLevel,+  compressStrategy    :: !Stream.CompressionStrategy,+  compressBufferSize  :: !Int+}++-- | The full set of parameters for decompression. The defaults are+-- 'defaultDecompressParams'.+--+-- The 'decompressBufferSize' is the size of the first output buffer,+-- containing the uncompressed data. If you know an exact or approximate upper+-- bound on the size of the decompressed data then setting this parameter can+-- save memory. The default decompression output buffer size is @32k@. If your+-- extimate is wrong it does not matter too much, the default buffer size will+-- be used for the remaining chunks.+--+-- One particular use case for setting the 'decompressBufferSize' is if you+-- know the exact size of the decompressed data and want to produce a strict+-- 'Data.ByteString.ByteString'. The compression and deccompression functions+-- use lazy 'Data.ByteString.Lazy.ByteString's but if you set the+-- 'decompressBufferSize' correctly then you can generate a lazy+-- 'Data.ByteString.Lazy.ByteString' with exactly one chunk, which can be+-- converted to a strict 'Data.ByteString.ByteString' in @O(1)@ time using+-- @'Data.ByteString.concat' . 'Data.ByteString.Lazy.toChunks'@.+--+data DecompressParams = DecompressParams {+  decompressWindowBits :: !Stream.WindowBits,+  decompressBufferSize :: !Int+}++-- | The default set of parameters for compression. This is typically used with+-- the @compressWith@ function with specific parameters overridden.+--+defaultCompressParams :: CompressParams+defaultCompressParams = CompressParams {+  compressLevel       = Stream.defaultCompression,+  compressMethod      = Stream.deflateMethod,+  compressWindowBits  = Stream.defaultWindowBits,+  compressMemoryLevel = Stream.defaultMemoryLevel,+  compressStrategy    = Stream.defaultStrategy,+  compressBufferSize  = defaultCompressBufferSize+}++-- | The default set of parameters for decompression. This is typically used with+-- the @compressWith@ function with specific parameters overridden.+--+defaultDecompressParams :: DecompressParams+defaultDecompressParams = DecompressParams {+  decompressWindowBits = Stream.defaultWindowBits,+  decompressBufferSize = defaultDecompressBufferSize+}++-- | The default chunk sizes for the output of compression and decompression+-- are 16k and 32k respectively (less a small accounting overhead).+--+defaultCompressBufferSize, defaultDecompressBufferSize :: Int+defaultCompressBufferSize   = 16 * 1024 - L.chunkOverhead+defaultDecompressBufferSize = 32 * 1024 - L.chunkOverhead++-- | A sequence of chunks of data produced from decompression.+--+-- The difference from a simple list is that it contains a representation of+-- errors as data rather than as exceptions. This allows you to handle error+-- conditions explicitly.+--+data DecompressStream = StreamEnd+                      | StreamChunk S.ByteString DecompressStream++                        -- | An error code and a human readable error message.+                      | StreamError DecompressError String++-- | The possible error cases when decompressing a stream.+--+data DecompressError =+     -- | The compressed data stream ended prematurely. This may happen if the+     -- input data stream was truncated.+     TruncatedInput++     -- | It is possible to do zlib compression with a custom dictionary. This+     -- allows slightly higher compression ratios for short files. However such+     -- compressed streams require the same dictionary when decompressing. This+     -- zlib binding does not currently support custom dictionaries. This error+     -- is for when we encounter a compressed stream that needs a dictionary.+   | DictionaryRequired++     -- | If the compressed data stream is corrupted in any way then you will+     -- get this error, for example if the input data just isn't a compressed+     -- zlib data stream. In particular if the data checksum turns out to be+     -- wrong then you will get all the decompressed data but this error at the+     -- end, instead of the normal sucessful 'StreamEnd'.+   | DataError++-- | Fold an 'DecompressionStream'. Just like 'foldr' but with an extra error+-- case. For example to convert to a list and translate the errors into+-- exceptions:+--+-- > foldDecompressStream (:) [] (\code msg -> error msg)+--+foldDecompressStream :: (S.ByteString -> a -> a) -> a+                 -> (DecompressError -> String -> a)+                 -> DecompressStream -> a+foldDecompressStream chunk end err = fold+  where+    fold StreamEnd               = end+    fold (StreamChunk bs stream) = chunk bs (fold stream)+    fold (StreamError code msg)  = err code msg++-- | Convert a 'DecompressStream' to a lazy 'ByteString'. If any decompression+-- errors are encountered then they are thrown as exceptions.+--+-- This is a special case of 'foldDecompressStream'.+--+fromDecompressStream :: DecompressStream -> L.ByteString+fromDecompressStream =+  foldDecompressStream L.Chunk L.Empty+    (\_code msg -> error ("Codec.Compression.Zlib: " ++ msg))++--TODO: throw DecompressError as an Exception class type and document that it+-- does this.++-- | Compress a data stream.+--+-- There are no expected error conditions. All input data streams are valid. It+-- is possible for unexpected errors to occur, such as running out of memory,+-- or finding the wrong version of the zlib C library, these are thrown as+-- exceptions.+--+compress+  :: Stream.Format+  -> CompressParams+  -> L.ByteString+  -> L.ByteString+compress format+  (CompressParams compLevel method bits memLevel strategy initChunkSize)+  input =+  L.fromChunks $ Stream.run $ do+    Stream.deflateInit format compLevel method bits memLevel strategy+    case L.toChunks input of+      [] -> fillBuffers 20 [] --gzip header is 20 bytes, others even smaller+      S.PS inFPtr offset length : chunks -> do+        Stream.pushInputBuffer inFPtr offset length+        fillBuffers initChunkSize chunks++  where+    -- we flick between two states:+    --   * where one or other buffer is empty+    --       - in which case we refill one or both+    --   * where both buffers are non-empty+    --       - in which case we compress until a buffer is empty++  fillBuffers :: Int+              -> [S.ByteString]+              -> Stream [S.ByteString]+  fillBuffers outChunkSize inChunks = do+#ifdef DEBUG+    Stream.consistencyCheck+#endif++    -- in this state there are two possabilities:+    --   * no outbut buffer space is available+    --       - in which case we must make more available+    --   * no input buffer is available+    --       - in which case we must supply more+    inputBufferEmpty <- Stream.inputBufferEmpty+    outputBufferFull <- Stream.outputBufferFull++    assert (inputBufferEmpty || outputBufferFull) $ return ()++    when outputBufferFull $ do+      outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)+      Stream.pushOutputBuffer outFPtr 0 outChunkSize++    if inputBufferEmpty+      then case inChunks of+             [] -> drainBuffers []+             S.PS inFPtr offset length : inChunks' -> do+                Stream.pushInputBuffer inFPtr offset length+                drainBuffers inChunks'+      else drainBuffers inChunks+++  drainBuffers ::+      [S.ByteString]+   -> Stream [S.ByteString]+  drainBuffers inChunks = do++    inputBufferEmpty' <- Stream.inputBufferEmpty+    outputBufferFull' <- Stream.outputBufferFull+    assert(not outputBufferFull'+       && (null inChunks || not inputBufferEmpty')) $ return ()+    -- this invariant guarantees we can always make forward progress+    -- and that therefore a BufferError is impossible++    let flush = if null inChunks then Stream.Finish else Stream.NoFlush+    status <- Stream.deflate flush++    case status of+      Stream.Ok -> do+        outputBufferFull <- Stream.outputBufferFull+        if outputBufferFull+          then do (outFPtr, offset, length) <- Stream.popOutputBuffer+                  outChunks <- Stream.unsafeInterleave+                    (fillBuffers defaultCompressBufferSize inChunks)+                  return (S.PS outFPtr offset length : outChunks)+          else do fillBuffers defaultCompressBufferSize inChunks++      Stream.StreamEnd -> do+        inputBufferEmpty <- Stream.inputBufferEmpty+        assert inputBufferEmpty $ return ()+        outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable+        if outputBufferBytesAvailable > 0+          then do (outFPtr, offset, length) <- Stream.popOutputBuffer+                  Stream.finalise+                  return [S.PS outFPtr offset length]+          else do Stream.finalise+                  return []++      Stream.Error code msg -> case code of+        Stream.BufferError  -> fail "BufferError should be impossible!"+        Stream.NeedDict     -> fail "NeedDict is impossible!"+        _                   -> fail msg+++-- | Decompress a data stream.+--+-- It will throw an exception if any error is encountered in the input data. If+-- you need more control over error handling then use 'decompressWithErrors'.+--+decompress+  :: Stream.Format+  -> DecompressParams+  -> L.ByteString+  -> L.ByteString+decompress format params = fromDecompressStream+                         . decompressWithErrors format params++-- | Like 'decompress' but returns a 'DecompressStream' data structure that+-- contains an explicit representation of the error conditions that one may+-- encounter when decompressing.+--+-- Note that in addition to errors in the input data, it is possible for other+-- unexpected errors to occur, such as out of memory, or finding the wrong+-- version of the zlib C library, these are still thrown as exceptions (because+-- representing them as data would make this function impure).+--+decompressWithErrors+  :: Stream.Format+  -> DecompressParams+  -> L.ByteString+  -> DecompressStream+decompressWithErrors format (DecompressParams bits initChunkSize) input =+  Stream.run $ do+    Stream.inflateInit format bits+    case L.toChunks input of+      [] -> fillBuffers 4 [] --always an error anyway+      S.PS inFPtr offset length : chunks -> do+        Stream.pushInputBuffer inFPtr offset length+        fillBuffers initChunkSize chunks++  where+    -- we flick between two states:+    --   * where one or other buffer is empty+    --       - in which case we refill one or both+    --   * where both buffers are non-empty+    --       - in which case we compress until a buffer is empty++  fillBuffers :: Int+              -> [S.ByteString]+              -> Stream DecompressStream+  fillBuffers outChunkSize inChunks = do+#ifdef DEBUG+    Stream.consistencyCheck+#endif++    -- in this state there are two possabilities:+    --   * no outbut buffer space is available+    --       - in which case we must make more available+    --   * no input buffer is available+    --       - in which case we must supply more+    inputBufferEmpty <- Stream.inputBufferEmpty+    outputBufferFull <- Stream.outputBufferFull++    assert (inputBufferEmpty || outputBufferFull) $ return ()++    when outputBufferFull $ do+      outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)+      Stream.pushOutputBuffer outFPtr 0 outChunkSize++    if inputBufferEmpty+      then case inChunks of+             [] -> drainBuffers []+             S.PS inFPtr offset length : inChunks' -> do+                Stream.pushInputBuffer inFPtr offset length+                drainBuffers inChunks'+      else drainBuffers inChunks+++  drainBuffers ::+      [S.ByteString]+   -> Stream DecompressStream+  drainBuffers inChunks = do++    inputBufferEmpty' <- Stream.inputBufferEmpty+    outputBufferFull' <- Stream.outputBufferFull+    assert(not outputBufferFull'+       && (null inChunks || not inputBufferEmpty')) $ return ()+    -- this invariant guarantees we can always make forward progress or at+    -- least if a BufferError does occur that it must be due to a premature EOF++    status <- Stream.inflate Stream.NoFlush++    case status of+      Stream.Ok -> do+        outputBufferFull <- Stream.outputBufferFull+        if outputBufferFull+          then do (outFPtr, offset, length) <- Stream.popOutputBuffer+                  outChunks <- Stream.unsafeInterleave+                    (fillBuffers defaultDecompressBufferSize inChunks)+                  return $ StreamChunk (S.PS outFPtr offset length) outChunks+          else do fillBuffers defaultDecompressBufferSize inChunks++      Stream.StreamEnd      -> finish StreamEnd+      Stream.Error code msg -> case code of+        Stream.BufferError  -> finish (StreamError TruncatedInput msg')+          where msg' = "premature end of compressed stream"+        Stream.NeedDict     -> finish (StreamError DictionaryRequired msg)+        Stream.DataError    -> finish (StreamError DataError msg)+        _                   -> fail msg++  -- Note even if we end with an error we still try to flush the last chunk if+  -- there is one. The user just has to decide what they want to trust.+  finish end = do+    -- Note that there may be input bytes still available if the stream+    -- is embeded in some other data stream. Here we just silently discard+    -- any trailing data.+    outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable+    if outputBufferBytesAvailable > 0+      then do (outFPtr, offset, length) <- Stream.popOutputBuffer+              Stream.finalise+              return (StreamChunk (S.PS outFPtr offset length) end)+      else do Stream.finalise+              return end
+ Codec/Compression/Zlib/Raw.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (c) 2006-2008 Duncan Coutts+-- License     :  BSD-style+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable (H98 + FFI)+--+-- Compression and decompression of data streams in the raw deflate format.+--+-- The format is described in detail in RFC #1951:+-- <http://www.ietf.org/rfc/rfc1951.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Raw (+  +  -- * Simple compression and decompression+  compress,+  decompress,++  -- * Extended api with control over compression parameters+  compressWith,+  decompressWith,++  CompressParams(..), defaultCompressParams,+  DecompressParams(..), defaultDecompressParams,++  -- ** The compression parameter types+  CompressionLevel(..),+    defaultCompression,+    noCompression,+    bestSpeed,+    bestCompression,+    compressionLevel,+  Method(..),+    deflateMethod,+  WindowBits(..),+    defaultWindowBits,+    windowBits,+  MemoryLevel(..),+    defaultMemoryLevel,+    minMemoryLevel,+    maxMemoryLevel,+    memoryLevel,+  CompressionStrategy(..),+    defaultStrategy,+    filteredStrategy,+    huffmanOnlyStrategy,++  ) where++import Data.ByteString.Lazy (ByteString)++import qualified Codec.Compression.Zlib.Internal as Internal+import Codec.Compression.Zlib.Internal hiding (compress, decompress)++decompress :: ByteString -> ByteString+decompress = decompressWith defaultDecompressParams++decompressWith :: DecompressParams -> ByteString -> ByteString+decompressWith = Internal.decompress rawFormat++compress :: ByteString -> ByteString+compress = compressWith defaultCompressParams++compressWith :: CompressParams -> ByteString -> ByteString+compressWith = Internal.compress rawFormat
+ Codec/Compression/Zlib/Stream.hsc view
@@ -0,0 +1,895 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (c) 2006-2008 Duncan Coutts+-- License     :  BSD-style+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable (H98 + FFI)+--+-- Zlib wrapper layer+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Stream (++  -- * The Zlib state monad+  Stream,+  run,+  unsafeInterleave,+  unsafeLiftIO,+  finalise,++  -- * Initialisation+  deflateInit, +  inflateInit,++  -- ** Initialisation parameters+  Format(..),+    gzipFormat,+    zlibFormat,+    rawFormat,+    gzipOrZlibFormat,+  CompressionLevel(..),+    defaultCompression,+    noCompression,+    bestSpeed,+    bestCompression,+    compressionLevel,+  Method(..),+    deflateMethod,+  WindowBits(..),+    defaultWindowBits,+    windowBits,+  MemoryLevel(..),+    defaultMemoryLevel,+    minMemoryLevel,+    maxMemoryLevel,+    memoryLevel,+  CompressionStrategy(..),+    defaultStrategy,+    filteredStrategy,+    huffmanOnlyStrategy,++  -- * The buisness+  deflate,+  inflate,+  Status(..),+  Flush(..),+  ErrorCode(..),++  -- * Buffer management+  -- ** Input buffer+  pushInputBuffer,+  inputBufferEmpty,++  -- ** Output buffer+  pushOutputBuffer,+  popOutputBuffer,+  outputBufferBytesAvailable,+  outputBufferSpaceRemaining,+  outputBufferFull,++#ifdef DEBUG+  -- * Debugging+  consistencyCheck,+  dump,+  trace,+#endif++  ) where++import Foreign+         ( Word8, Ptr, nullPtr, plusPtr, peekByteOff, pokeByteOff, mallocBytes+         , ForeignPtr, FinalizerPtr, newForeignPtr_, addForeignPtrFinalizer+         , withForeignPtr, touchForeignPtr )+#if __GLASGOW_HASKELL__ >= 702+import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr )+import System.IO.Unsafe          ( unsafePerformIO )+#else+import Foreign ( unsafeForeignPtrToPtr, unsafePerformIO )+#endif+#ifdef __GLASGOW_HASKELL__+import Foreign+         ( finalizeForeignPtr )+#endif+import Foreign.C+import Data.ByteString.Internal (nullForeignPtr)+import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Monad (liftM)+import Control.Exception (assert)+#ifdef DEBUG+import System.IO (hPutStrLn, stderr)+#endif++import Prelude hiding (length)++#include "zlib.h"+++pushInputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()+pushInputBuffer inBuf' offset length = do++  -- must not push a new input buffer if the last one is not used up+  inAvail <- getInAvail+  assert (inAvail == 0) $ return ()++  -- Now that we're setting a new input buffer, we can be sure that zlib no+  -- longer has a reference to the old one. Therefore this is the last point+  -- at which the old buffer had to be retained. It's safe to release now.+  inBuf <- getInBuf +  unsafeLiftIO $ touchForeignPtr inBuf    ++  -- now set the available input buffer ptr and length+  setInBuf   inBuf'+  setInAvail length+  setInNext  (unsafeForeignPtrToPtr inBuf' `plusPtr` offset)+  -- Note the 'unsafe'. We are passing the raw ptr inside inBuf' to zlib.+  -- To make this safe we need to hold on to the ForeignPtr for at least as+  -- long as zlib is using the underlying raw ptr.+++inputBufferEmpty :: Stream Bool+inputBufferEmpty = getInAvail >>= return . (==0)+++pushOutputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()+pushOutputBuffer outBuf' offset length = do++  --must not push a new buffer if there is still data in the old one+  outAvail <- getOutAvail+  assert (outAvail == 0) $ return ()+  -- Note that there may still be free space in the output buffer, that's ok,+  -- you might not want to bother completely filling the output buffer say if+  -- there's only a few free bytes left.++  outBuf <- getOutBuf+  unsafeLiftIO $ touchForeignPtr outBuf++  -- now set the available input buffer ptr and length+  setOutBuf  outBuf'+  setOutFree length+  setOutNext (unsafeForeignPtrToPtr outBuf' `plusPtr` offset)++  setOutOffset offset+  setOutAvail  0+++-- get that part of the output buffer that is currently full+-- (might be 0, use outputBufferBytesAvailable to check)+-- this may leave some space remaining in the buffer, use+-- outputBufferSpaceRemaining to check.+popOutputBuffer :: Stream (ForeignPtr Word8, Int, Int)+popOutputBuffer = do++  outBuf    <- getOutBuf+  outOffset <- getOutOffset+  outAvail  <- getOutAvail++  -- there really should be something to pop, otherwise it's silly+  assert (outAvail > 0) $ return ()++  setOutOffset (outOffset + outAvail)+  setOutAvail  0++  return (outBuf, outOffset, outAvail)+++-- this is the number of bytes available in the output buffer+outputBufferBytesAvailable :: Stream Int+outputBufferBytesAvailable = getOutAvail+++-- you needen't get all the output immediately, you can continue until+-- there is no more output space available, this tells you that amount+outputBufferSpaceRemaining :: Stream Int+outputBufferSpaceRemaining = getOutFree+++-- you only need to supply a new buffer when there is no more output buffer+-- space remaining+outputBufferFull :: Stream Bool+outputBufferFull = liftM (==0) outputBufferSpaceRemaining+++-- you can only run this when the output buffer is not empty+-- you can run it when the input buffer is empty but it doesn't do anything+-- after running deflate either the output buffer will be full+-- or the input buffer will be empty (or both)+deflate :: Flush -> Stream Status+deflate flush = do++  outFree <- getOutFree++  -- deflate needs free space in the output buffer+  assert (outFree > 0) $ return ()++  result <- deflate_ flush+  outFree' <- getOutFree+    +  -- number of bytes of extra output there is available as a result of+  -- the call to deflate:+  let outExtra = outFree - outFree'+  +  outAvail <- getOutAvail+  setOutAvail (outAvail + outExtra)+  return result+++inflate :: Flush -> Stream Status+inflate flush = do++  outFree <- getOutFree++  -- inflate needs free space in the output buffer+  assert (outFree > 0) $ return ()++  result <- inflate_ flush+  outFree' <- getOutFree++  -- number of bytes of extra output there is available as a result of+  -- the call to inflate:+  let outExtra = outFree - outFree'++  outAvail <- getOutAvail+  setOutAvail (outAvail + outExtra)+  return result+++----------------------------+-- Stream monad+--++newtype Stream a = Z {+    unZ :: ForeignPtr StreamState+        -> ForeignPtr Word8+        -> ForeignPtr Word8+        -> Int -> Int+        -> IO (ForeignPtr Word8+              ,ForeignPtr Word8+              ,Int, Int, a)+  }++instance Monad Stream where+  (>>=)  = thenZ+--  m >>= f = (m `thenZ` \a -> consistencyCheck `thenZ_` returnZ a) `thenZ` f+  (>>)   = thenZ_+  return = returnZ+  fail   = (finalise >>) . failZ++returnZ :: a -> Stream a+returnZ a = Z $ \_ inBuf outBuf outOffset outLength ->+                  return (inBuf, outBuf, outOffset, outLength, a)+{-# INLINE returnZ #-}++thenZ :: Stream a -> (a -> Stream b) -> Stream b+thenZ (Z m) f =+  Z $ \stream inBuf outBuf outOffset outLength ->+    m stream inBuf outBuf outOffset outLength >>=+      \(inBuf', outBuf', outOffset', outLength', a) ->+        unZ (f a) stream inBuf' outBuf' outOffset' outLength'+{-# INLINE thenZ #-}++thenZ_ :: Stream a -> Stream b -> Stream b+thenZ_ (Z m) f =+  Z $ \stream inBuf outBuf outOffset outLength ->+    m stream inBuf outBuf outOffset outLength >>=+      \(inBuf', outBuf', outOffset', outLength', _) ->+        unZ f stream inBuf' outBuf' outOffset' outLength'+{-# INLINE thenZ_ #-}++failZ :: String -> Stream a+failZ msg = Z (\_ _ _ _ _ -> fail ("Codec.Compression.Zlib: " ++ msg))++{-# NOINLINE run #-}+run :: Stream a -> a+run (Z m) = unsafePerformIO $ do+  ptr <- mallocBytes (#{const sizeof(z_stream)})+  #{poke z_stream, msg}       ptr nullPtr+  #{poke z_stream, zalloc}    ptr nullPtr+  #{poke z_stream, zfree}     ptr nullPtr+  #{poke z_stream, opaque}    ptr nullPtr+  #{poke z_stream, next_in}   ptr nullPtr+  #{poke z_stream, next_out}  ptr nullPtr+  #{poke z_stream, avail_in}  ptr (0 :: CUInt)+  #{poke z_stream, avail_out} ptr (0 :: CUInt)+  stream <- newForeignPtr_ ptr+  (_,_,_,_,a) <- m stream nullForeignPtr nullForeignPtr 0 0+  return a++-- This is marked as unsafe because run uses unsafePerformIO so anything+-- lifted here will end up being unsafePerformIO'd.+unsafeLiftIO :: IO a -> Stream a+unsafeLiftIO m = Z $ \_stream inBuf outBuf outOffset outLength -> do+  a <- m+  return (inBuf, outBuf, outOffset, outLength, a)++-- It's unsafe because we discard the values here, so if you mutate anything+-- between running this and forcing the result then you'll get an inconsistent+-- stream state.+unsafeInterleave :: Stream a -> Stream a+unsafeInterleave (Z m) = Z $ \stream inBuf outBuf outOffset outLength -> do+  res <- unsafeInterleaveIO (m stream inBuf outBuf outOffset outLength)+  let select (_,_,_,_,a) = a+  return (inBuf, outBuf, outOffset, outLength, select res)++getStreamState :: Stream (ForeignPtr StreamState)+getStreamState = Z $ \stream inBuf outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, stream)++getInBuf :: Stream (ForeignPtr Word8)+getInBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, inBuf)++getOutBuf :: Stream (ForeignPtr Word8)+getOutBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, outBuf)++getOutOffset :: Stream Int+getOutOffset = Z $ \_stream inBuf outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, outOffset)++getOutAvail :: Stream Int+getOutAvail = Z $ \_stream inBuf outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, outLength)++setInBuf :: ForeignPtr Word8 -> Stream ()+setInBuf inBuf = Z $ \_stream _ outBuf outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, ())++setOutBuf :: ForeignPtr Word8 -> Stream ()+setOutBuf outBuf = Z $ \_stream inBuf _ outOffset outLength -> do+  return (inBuf, outBuf, outOffset, outLength, ())++setOutOffset :: Int -> Stream ()+setOutOffset outOffset = Z $ \_stream inBuf outBuf _ outLength -> do+  return (inBuf, outBuf, outOffset, outLength, ())++setOutAvail :: Int -> Stream ()+setOutAvail outLength = Z $ \_stream inBuf outBuf outOffset _ -> do+  return (inBuf, outBuf, outOffset, outLength, ())++----------------------------+-- Debug stuff+--++#ifdef DEBUG+trace :: String -> Stream ()+trace = unsafeLiftIO . hPutStrLn stderr++dump :: Stream ()+dump = do+  inNext  <- getInNext+  inAvail <- getInAvail++  outNext <- getOutNext+  outFree <- getOutFree+  outAvail <- getOutAvail+  outOffset <- getOutOffset++  unsafeLiftIO $ hPutStrLn stderr $+    "Stream {\n" +++    "  inNext    = " ++ show inNext    ++ ",\n" +++    "  inAvail   = " ++ show inAvail   ++ ",\n" +++    "\n" +++    "  outNext   = " ++ show outNext   ++ ",\n" +++    "  outFree   = " ++ show outFree   ++ ",\n" +++    "  outAvail  = " ++ show outAvail  ++ ",\n" +++    "  outOffset = " ++ show outOffset ++ "\n"  +++    "}"++  consistencyCheck++consistencyCheck :: Stream ()+consistencyCheck = do++  outBuf    <- getOutBuf+  outOffset <- getOutOffset+  outAvail  <- getOutAvail+  outNext   <- getOutNext++  let outBufPtr = unsafeForeignPtrToPtr outBuf++  assert (outBufPtr `plusPtr` (outOffset + outAvail) == outNext) $ return ()+#endif+++----------------------------+-- zlib wrapper layer+--++data Status =+    Ok+  | StreamEnd+  | Error ErrorCode String++data ErrorCode =+    NeedDict+  | FileError+  | StreamError+  | DataError+  | MemoryError+  | BufferError -- ^ No progress was possible or there was not enough room in+                --   the output buffer when 'Finish' is used. Note that+                --   'BuferError' is not fatal, and 'inflate' can be called+                --   again with more input and more output space to continue.+  | VersionError+  | Unexpected++toStatus :: CInt -> Stream Status+toStatus errno = case errno of+  (#{const Z_OK})            -> return Ok+  (#{const Z_STREAM_END})    -> return StreamEnd+  (#{const Z_NEED_DICT})     -> err NeedDict     "custom dictionary needed"+  (#{const Z_BUF_ERROR})     -> err BufferError  "buffer error"+  (#{const Z_ERRNO})         -> err FileError    "file error"+  (#{const Z_STREAM_ERROR})  -> err StreamError  "stream error"+  (#{const Z_DATA_ERROR})    -> err DataError    "data error"+  (#{const Z_MEM_ERROR})     -> err MemoryError  "insufficient memory"+  (#{const Z_VERSION_ERROR}) -> err VersionError "incompatible zlib version"+  other                      -> return $ Error Unexpected+                                  ("unexpected zlib status: " ++ show other)+ where+   err errCode altMsg = liftM (Error errCode) $ do+    msgPtr <- withStreamPtr (#{peek z_stream, msg})+    if msgPtr /= nullPtr+     then unsafeLiftIO (peekCAString msgPtr)+     else return altMsg++failIfError :: CInt -> Stream ()+failIfError errno = toStatus errno >>= \status -> case status of+  (Error _ msg) -> fail msg+  _             -> return ()+++data Flush =+    NoFlush+  | SyncFlush+  | FullFlush+  | Finish+--  | Block -- only available in zlib 1.2 and later, uncomment if you need it.++fromFlush :: Flush -> CInt+fromFlush NoFlush   = #{const Z_NO_FLUSH}+fromFlush SyncFlush = #{const Z_SYNC_FLUSH}+fromFlush FullFlush = #{const Z_FULL_FLUSH}+fromFlush Finish    = #{const Z_FINISH}+--  fromFlush Block     = #{const Z_BLOCK}+++-- | The format used for compression or decompression. There are three+-- variations.+--+data Format = GZip | Zlib | Raw | GZipOrZlib+  deriving Eq++{-# DEPRECATED GZip       "Use gzipFormat. Format constructors will be hidden in version 0.7"       #-}+{-# DEPRECATED Zlib       "Use zlibFormat. Format constructors will be hidden in version 0.7"       #-}+{-# DEPRECATED Raw        "Use rawFormat. Format constructors will be hidden in version 0.7"        #-}+{-# DEPRECATED GZipOrZlib "Use gzipOrZlibFormat. Format constructors will be hidden in version 0.7" #-}++-- | The gzip format uses a header with a checksum and some optional meta-data+-- about the compressed file. It is intended primarily for compressing+-- individual files but is also sometimes used for network protocols such as+-- HTTP. The format is described in detail in RFC #1952+-- <http://www.ietf.org/rfc/rfc1952.txt>+--+gzipFormat :: Format+gzipFormat = GZip++-- | The zlib format uses a minimal header with a checksum but no other+-- meta-data. It is especially designed for use in network protocols. The+-- format is described in detail in RFC #1950+-- <http://www.ietf.org/rfc/rfc1950.txt>+--+zlibFormat :: Format+zlibFormat = Zlib++-- | The \'raw\' format is just the compressed data stream without any+-- additional header, meta-data or data-integrity checksum. The format is+-- described in detail in RFC #1951 <http://www.ietf.org/rfc/rfc1951.txt>+--+rawFormat :: Format+rawFormat = Raw++-- | This is not a format as such. It enabled zlib or gzip decoding with+-- automatic header detection. This only makes sense for decompression.+--+gzipOrZlibFormat :: Format+gzipOrZlibFormat = GZipOrZlib+++-- | The compression method+--+data Method = Deflated++{-# DEPRECATED Deflated "Use deflateMethod. Method constructors will be hidden in version 0.7" #-}++-- | \'Deflate\' is the only method supported in this version of zlib.+-- Indeed it is likely to be the only method that ever will be supported.+--+deflateMethod :: Method+deflateMethod = Deflated++fromMethod :: Method -> CInt+fromMethod Deflated = #{const Z_DEFLATED}+++-- | The compression level parameter controls the amount of compression. This+-- is a trade-off between the amount of compression and the time required to do+-- the compression.+--+data CompressionLevel = +    DefaultCompression+  | NoCompression+  | BestSpeed+  | BestCompression+  | CompressionLevel Int++{-# DEPRECATED DefaultCompression "Use defaultCompression. CompressionLevel constructors will be hidden in version 0.7" #-}+{-# DEPRECATED NoCompression      "Use noCompression. CompressionLevel constructors will be hidden in version 0.7"      #-}+{-# DEPRECATED BestSpeed          "Use bestSpeed. CompressionLevel constructors will be hidden in version 0.7"          #-}+{-# DEPRECATED BestCompression    "Use bestCompression. CompressionLevel constructors will be hidden in version 0.7"    #-}+--FIXME: cannot deprecate constructor named the same as the type+{- DEPRECATED CompressionLevel   "Use compressionLevel. CompressionLevel constructors will be hidden in version 0.7"   -}++-- | The default compression level is 6 (that is, biased towards higher+-- compression at expense of speed).+defaultCompression :: CompressionLevel+defaultCompression = DefaultCompression++-- | No compression, just a block copy.+noCompression :: CompressionLevel+noCompression = CompressionLevel 0++-- | The fastest compression method (less compression)+bestSpeed :: CompressionLevel+bestSpeed = CompressionLevel 1++-- | The slowest compression method (best compression).+bestCompression :: CompressionLevel+bestCompression = CompressionLevel 9++-- | A specific compression level between 0 and 9.+compressionLevel :: Int -> CompressionLevel+compressionLevel n+  | n >= 0 && n <= 9 = CompressionLevel n+  | otherwise        = error "CompressionLevel must be in the range 0..9"++fromCompressionLevel :: CompressionLevel -> CInt+fromCompressionLevel DefaultCompression   = -1+fromCompressionLevel NoCompression        = 0+fromCompressionLevel BestSpeed            = 1+fromCompressionLevel BestCompression      = 9+fromCompressionLevel (CompressionLevel n)+           | n >= 0 && n <= 9 = fromIntegral n+           | otherwise        = error "CompressLevel must be in the range 1..9"+++-- | This specifies the size of the compression window. Larger values of this+-- parameter result in better compression at the expense of higher memory+-- usage.+--+-- The compression window size is the value of the the window bits raised to+-- the power 2. The window bits must be in the range @8..15@ which corresponds+-- to compression window sizes of 256b to 32Kb. The default is 15 which is also+-- the maximum size.+--+-- The total amount of memory used depends on the window bits and the+-- 'MemoryLevel'. See the 'MemoryLevel' for the details.+--+data WindowBits = WindowBits Int+                | DefaultWindowBits -- This constructor must be last to make+		                    -- the Ord instance work. The Ord instance+				    -- is defined with and used by the tests.+				    -- It makse sense because the default value+				    -- is is also the max value at 15.++{-# DEPRECATED DefaultWindowBits  "Use defaultWindowBits. WindowBits constructors will be hidden in version 0.7" #-}+--FIXME: cannot deprecate constructor named the same as the type+{- DEPRECATED WindowBits         "Use windowBits. WindowBits constructors will be hidden in version 0.7"        -}++-- | The default 'WindowBits' is 15 which is also the maximum size.+--+defaultWindowBits :: WindowBits+defaultWindowBits = WindowBits 15++-- | A specific compression window size, specified in bits in the range @8..15@+--+windowBits :: Int -> WindowBits+windowBits n+  | n >= 8 && n <= 15 = WindowBits n+  | otherwise         = error "WindowBits must be in the range 8..15"++fromWindowBits :: Format -> WindowBits-> CInt+fromWindowBits format bits = (formatModifier format) (checkWindowBits bits)+  where checkWindowBits DefaultWindowBits = 15+        checkWindowBits (WindowBits n)+          | n >= 8 && n <= 15 = fromIntegral n+          | otherwise         = error "WindowBits must be in the range 8..15"+        formatModifier Zlib       = id+        formatModifier GZip       = (+16)+        formatModifier GZipOrZlib = (+32)+        formatModifier Raw        = negate+++-- | The 'MemoryLevel' parameter specifies how much memory should be allocated+-- for the internal compression state. It is a tradoff between memory usage,+-- compression ratio and compression speed. Using more memory allows faster+-- compression and a better compression ratio.+--+-- The total amount of memory used for compression depends on the 'WindowBits'+-- and the 'MemoryLevel'. For decompression it depends only on the+-- 'WindowBits'. The totals are given by the functions:+--+-- > compressTotal windowBits memLevel = 4 * 2^windowBits + 512 * 2^memLevel+-- > decompressTotal windowBits = 2^windowBits+--+-- For example, for compression with the default @windowBits = 15@ and+-- @memLevel = 8@ uses @256Kb@. So for example a network server with 100+-- concurrent compressed streams would use @25Mb@. The memory per stream can be+-- halved (at the cost of somewhat degraded and slower compressionby) by+-- reducing the @windowBits@ and @memLevel@ by one.+--+-- Decompression takes less memory, the default @windowBits = 15@ corresponds+-- to just @32Kb@.+--+data MemoryLevel =+    DefaultMemoryLevel+  | MinMemoryLevel+  | MaxMemoryLevel+  | MemoryLevel Int++{-# DEPRECATED DefaultMemoryLevel "Use defaultMemoryLevel. MemoryLevel constructors will be hidden in version 0.7" #-}+{-# DEPRECATED MinMemoryLevel     "Use minMemoryLevel. MemoryLevel constructors will be hidden in version 0.7"     #-}+{-# DEPRECATED MaxMemoryLevel     "Use maxMemoryLevel. MemoryLevel constructors will be hidden in version 0.7"     #-}+--FIXME: cannot deprecate constructor named the same as the type+{- DEPRECATED MemoryLevel        "Use memoryLevel. MemoryLevel constructors will be hidden in version 0.7"        -}++-- | The default memory level. (Equivalent to @'memoryLevel' 8@)+--+defaultMemoryLevel :: MemoryLevel+defaultMemoryLevel = MemoryLevel 8++-- | Use minimum memory. This is slow and reduces the compression ratio.+-- (Equivalent to @'memoryLevel' 1@)+--+minMemoryLevel :: MemoryLevel+minMemoryLevel = MemoryLevel 1++-- | Use maximum memory for optimal compression speed.+-- (Equivalent to @'memoryLevel' 9@)+--+maxMemoryLevel :: MemoryLevel+maxMemoryLevel = MemoryLevel 9++-- | A specific level in the range @1..9@+--+memoryLevel :: Int -> MemoryLevel+memoryLevel n+  | n >= 1 && n <= 9 = MemoryLevel n+  | otherwise        = error "MemoryLevel must be in the range 1..9"++fromMemoryLevel :: MemoryLevel -> CInt+fromMemoryLevel DefaultMemoryLevel = 8+fromMemoryLevel MinMemoryLevel     = 1+fromMemoryLevel MaxMemoryLevel     = 9+fromMemoryLevel (MemoryLevel n)+         | n >= 1 && n <= 9 = fromIntegral n+         | otherwise        = error "MemoryLevel must be in the range 1..9"+++-- | The strategy parameter is used to tune the compression algorithm.+--+-- The strategy parameter only affects the compression ratio but not the+-- correctness of the compressed output even if it is not set appropriately.+--+data CompressionStrategy =+    DefaultStrategy+  | Filtered+  | HuffmanOnly++{-+-- -- only available in zlib 1.2 and later, uncomment if you need it.+  | RLE             -- ^ Use 'RLE' to limit match distances to one (run-length+                    --   encoding). 'RLE' is designed to be almost as fast as+                    --   'HuffmanOnly', but give better compression for PNG+                    --   image data.+  | Fixed           -- ^ 'Fixed' prevents the use of dynamic Huffman codes,+                    --   allowing for a simpler decoder for special applications.+-}++{-# DEPRECATED DefaultStrategy "Use defaultStrategy. CompressionStrategy constructors will be hidden in version 0.7"     #-}+{-# DEPRECATED Filtered        "Use filteredStrategy. CompressionStrategy constructors will be hidden in version 0.7"    #-}+{-# DEPRECATED HuffmanOnly     "Use huffmanOnlyStrategy. CompressionStrategy constructors will be hidden in version 0.7" #-}++-- | Use this default compression strategy for normal data.+--+defaultStrategy :: CompressionStrategy+defaultStrategy = DefaultStrategy++-- | Use the filtered compression strategy for data produced by a filter (or+-- predictor). Filtered data consists mostly of small values with a somewhat+-- random distribution. In this case, the compression algorithm is tuned to+-- compress them better. The effect of this strategy is to force more Huffman+-- coding and less string matching; it is somewhat intermediate between+-- 'defaultCompressionStrategy' and 'huffmanOnlyCompressionStrategy'.+--+filteredStrategy :: CompressionStrategy+filteredStrategy = Filtered++-- | Use the Huffman-only compression strategy to force Huffman encoding only+-- (no string match).+--+huffmanOnlyStrategy :: CompressionStrategy+huffmanOnlyStrategy = HuffmanOnly+++fromCompressionStrategy :: CompressionStrategy -> CInt+fromCompressionStrategy DefaultStrategy = #{const Z_DEFAULT_STRATEGY}+fromCompressionStrategy Filtered        = #{const Z_FILTERED}+fromCompressionStrategy HuffmanOnly     = #{const Z_HUFFMAN_ONLY}+--fromCompressionStrategy RLE             = #{const Z_RLE}+--fromCompressionStrategy Fixed           = #{const Z_FIXED}+++withStreamPtr :: (Ptr StreamState -> IO a) -> Stream a+withStreamPtr f = do+  stream <- getStreamState+  unsafeLiftIO (withForeignPtr stream f)++withStreamState :: (StreamState -> IO a) -> Stream a+withStreamState f = do+  stream <- getStreamState+  unsafeLiftIO (withForeignPtr stream (f . StreamState))++setInAvail :: Int -> Stream ()+setInAvail val = withStreamPtr $ \ptr ->+  #{poke z_stream, avail_in} ptr (fromIntegral val :: CUInt)++getInAvail :: Stream Int+getInAvail = liftM (fromIntegral :: CUInt -> Int) $+  withStreamPtr (#{peek z_stream, avail_in})++setInNext :: Ptr Word8 -> Stream ()+setInNext val = withStreamPtr (\ptr -> #{poke z_stream, next_in} ptr val)++#ifdef DEBUG+getInNext :: Stream (Ptr Word8)+getInNext = withStreamPtr (#{peek z_stream, next_in})+#endif++setOutFree :: Int -> Stream ()+setOutFree val = withStreamPtr $ \ptr ->+  #{poke z_stream, avail_out} ptr (fromIntegral val :: CUInt)++getOutFree :: Stream Int+getOutFree = liftM (fromIntegral :: CUInt -> Int) $+  withStreamPtr (#{peek z_stream, avail_out})++setOutNext  :: Ptr Word8 -> Stream ()+setOutNext val = withStreamPtr (\ptr -> #{poke z_stream, next_out} ptr val)++#ifdef DEBUG+getOutNext :: Stream (Ptr Word8)+getOutNext = withStreamPtr (#{peek z_stream, next_out})+#endif++inflateInit :: Format -> WindowBits -> Stream ()+inflateInit format bits = do+  checkFormatSupported format+  err <- withStreamState $ \zstream ->+    c_inflateInit2 zstream (fromIntegral (fromWindowBits format bits))+  failIfError err+  getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_inflateEnd++deflateInit :: Format+            -> CompressionLevel+            -> Method+            -> WindowBits+            -> MemoryLevel+            -> CompressionStrategy+            -> Stream ()+deflateInit format compLevel method bits memLevel strategy = do+  checkFormatSupported format+  err <- withStreamState $ \zstream ->+    c_deflateInit2 zstream+                  (fromCompressionLevel compLevel)+                  (fromMethod method)+                  (fromWindowBits format bits)+                  (fromMemoryLevel memLevel)+                  (fromCompressionStrategy strategy)+  failIfError err+  getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_deflateEnd++inflate_ :: Flush -> Stream Status+inflate_ flush = do+  err <- withStreamState $ \zstream ->+    c_inflate zstream (fromFlush flush)+  toStatus err++deflate_ :: Flush -> Stream Status+deflate_ flush = do+  err <- withStreamState $ \zstream ->+    c_deflate zstream (fromFlush flush)+  toStatus err++-- | This never needs to be used as the stream's resources will be released+-- automatically when no longer needed, however this can be used to release+-- them early. Only use this when you can guarantee that the stream will no+-- longer be needed, for example if an error occurs or if the stream ends.+--+finalise :: Stream ()+#ifdef __GLASGOW_HASKELL__+--TODO: finalizeForeignPtr is ghc-only+finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr+#else+finalise = return ()+#endif++checkFormatSupported :: Format -> Stream ()+checkFormatSupported format = do+  version <- unsafeLiftIO (peekCAString =<< c_zlibVersion)+  case version of+    ('1':'.':'1':'.':_)+       | format == GZip+      || format == GZipOrZlib+      -> fail $ "version 1.1.x of the zlib C library does not support the"+             ++ " 'gzip' format via the in-memory api, only the 'raw' and "+	     ++ " 'zlib' formats."+    _ -> return ()++----------------------+-- The foreign imports++newtype StreamState = StreamState (Ptr StreamState)++-- inflateInit2 and deflateInit2 are actually defined as macros in zlib.h+-- They are defined in terms of inflateInit2_ and deflateInit2_ passing two+-- additional arguments used to detect compatability problems. They pass the+-- version of zlib as a char * and the size of the z_stream struct.+-- If we compile via C then we can avoid this hassle however thats not really+-- kosher since the Haskell FFI is defined at the C ABI level, not the C+-- language level. There is no requirement to compile via C and pick up C+-- headers. So it's much better if we can make it work properly and that'd+-- also allow compiling via ghc's ncg which is a good thing since the C+-- backend is not going to be around forever.+--+-- So we define c_inflateInit2 and c_deflateInit2 here as wrappers around+-- their _ counterparts and pass the extra args.++foreign import ccall unsafe "zlib.h inflateInit2_"+  c_inflateInit2_ :: StreamState -> CInt -> Ptr CChar -> CInt -> IO CInt++c_inflateInit2 :: StreamState -> CInt -> IO CInt+c_inflateInit2 z n =+  withCAString #{const_str ZLIB_VERSION} $ \versionStr ->+    c_inflateInit2_ z n versionStr (#{const sizeof(z_stream)} :: CInt)++foreign import ccall unsafe "zlib.h inflate"+  c_inflate :: StreamState -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h &inflateEnd"+  c_inflateEnd :: FinalizerPtr StreamState+++foreign import ccall unsafe "zlib.h deflateInit2_"+  c_deflateInit2_ :: StreamState+                  -> CInt -> CInt -> CInt -> CInt -> CInt+		  -> Ptr CChar -> CInt+		  -> IO CInt++c_deflateInit2 :: StreamState+               -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt+c_deflateInit2 z a b c d e =+  withCAString #{const_str ZLIB_VERSION} $ \versionStr ->+    c_deflateInit2_ z a b c d e versionStr (#{const sizeof(z_stream)} :: CInt)++foreign import ccall unsafe "zlib.h deflate"+  c_deflate :: StreamState -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h &deflateEnd"+  c_deflateEnd :: FinalizerPtr StreamState++foreign import ccall unsafe "zlib.h zlibVersion"+  c_zlibVersion :: IO CString
+ Control/Applicative/Backwards.hs view
@@ -0,0 +1,49 @@+-- |+-- Module      :  Control.Applicative.Backwards+-- Copyright   :  (c) Russell O'Connor 2009+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Making functors with an 'Applicative' instance that performs actions+-- in the reverse order.++module Control.Applicative.Backwards where++import Prelude hiding (foldr, foldr1, foldl, foldl1)+import Control.Applicative+import Data.Foldable+import Data.Traversable++-- | The same functor, but with an 'Applicative' instance that performs+-- actions in the reverse order.+newtype Backwards f a = Backwards { forwards :: f a }++-- | Derived instance.+instance (Functor f) => Functor (Backwards f) where+    fmap f (Backwards a) = Backwards (fmap f a)++-- | Apply @f@-actions in the reverse order.+instance (Applicative f) => Applicative (Backwards f) where+    pure a = Backwards (pure a)+    Backwards f <*> Backwards a = Backwards (a <**> f)++-- | Try alternatives in the same order as @f@.+instance (Alternative f) => Alternative (Backwards f) where+    empty = Backwards empty+    Backwards x <|> Backwards y = Backwards (x <|> y)++-- | Derived instance.+instance (Foldable f) => Foldable (Backwards f) where+    foldMap f (Backwards t) = foldMap f t+    foldr f z (Backwards t) = foldr f z t+    foldl f z (Backwards t) = foldl f z t+    foldr1 f (Backwards t) = foldl1 f t+    foldl1 f (Backwards t) = foldr1 f t++-- | Derived instance.+instance (Traversable f) => Traversable (Backwards f) where+    traverse f (Backwards t) = fmap Backwards (traverse f t)+    sequenceA (Backwards t) = fmap Backwards (sequenceA t)
+ Control/Applicative/Lift.hs view
@@ -0,0 +1,68 @@+-- |+-- Module      :  Control.Applicative.Lift+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Adding a new kind of pure computation to an applicative functor.++module Control.Applicative.Lift (+    Lift(..), unLift,+    -- * Collecting errors+    Errors, failure+  ) where++import Control.Applicative+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Constant+import Data.Monoid (Monoid(mappend))+import Data.Traversable (Traversable(traverse))++-- | Applicative functor formed by adding pure computations to a given+-- applicative functor.+data Lift f a = Pure a | Other (f a)++instance (Functor f) => Functor (Lift f) where+    fmap f (Pure x) = Pure (f x)+    fmap f (Other y) = Other (fmap f y)++instance (Foldable f) => Foldable (Lift f) where+    foldMap f (Pure x) = f x+    foldMap f (Other y) = foldMap f y++instance (Traversable f) => Traversable (Lift f) where+    traverse f (Pure x) = Pure <$> f x+    traverse f (Other y) = Other <$> traverse f y++-- | A combination is 'Pure' only if both parts are.+instance (Applicative f) => Applicative (Lift f) where+    pure = Pure+    Pure f <*> Pure x = Pure (f x)+    Pure f <*> Other y = Other (f <$> y)+    Other f <*> Pure x = Other (($ x) <$> f)+    Other f <*> Other y = Other (f <*> y)++-- | A combination is 'Pure' only either part is.+instance Alternative f => Alternative (Lift f) where+    empty = Other empty+    Pure x <|> _ = Pure x+    Other _ <|> Pure y = Pure y+    Other x <|> Other y = Other (x <|> y)++-- | Projection to the other functor.+unLift :: Applicative f => Lift f a -> f a+unLift (Pure x) = pure x+unLift (Other e) = e++-- | An applicative functor that collects a monoid (e.g. lists) of errors.+-- A sequence of computations fails if any of its components do, but+-- unlike monads made with 'ErrorT' from "Control.Monad.Trans.Error",+-- these computations continue after an error, collecting all the errors.+type Errors e = Lift (Constant e)++-- | Report an error.+failure :: Monoid e => e -> Errors e a+failure e = Other (Constant e)
+ Control/Monad/Cont.hs view
@@ -0,0 +1,168 @@+{- |+Module      :  Control.Monad.Cont+Copyright   :  (c) The University of Glasgow 2001,+               (c) Jeff Newbern 2003-2007,+               (c) Andriy Palamarchuk 2007+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  portable++[Computation type:] Computations which can be interrupted and resumed.++[Binding strategy:] Binding a function to a monadic value creates+a new continuation which uses the function as the continuation of the monadic+computation.++[Useful for:] Complex control structures, error handling,+and creating co-routines.++[Zero and plus:] None.++[Example type:] @'Cont' r a@++The Continuation monad represents computations in continuation-passing style+(CPS).+In continuation-passing style function result is not returned,+but instead is passed to another function,+received as a parameter (continuation).+Computations are built up from sequences+of nested continuations, terminated by a final continuation (often @id@)+which produces the final result.+Since continuations are functions which represent the future of a computation,+manipulation of the continuation functions can achieve complex manipulations+of the future of the computation,+such as interrupting a computation in the middle, aborting a portion+of a computation, restarting a computation, and interleaving execution of+computations.+The Continuation monad adapts CPS to the structure of a monad.++Before using the Continuation monad, be sure that you have+a firm understanding of continuation-passing style+and that continuations represent the best solution to your particular+design problem.+Many algorithms which require continuations in other languages do not require+them in Haskell, due to Haskell's lazy semantics.+Abuse of the Continuation monad can produce code that is impossible+to understand and maintain.+-}++module Control.Monad.Cont (+    -- * MonadCont class+    MonadCont(..),+    -- * The Cont monad+    Cont,+    cont,+    runCont,+    mapCont,+    withCont,+    -- * The ContT monad transformer+    ContT(..),+    mapContT,+    withContT,+    module Control.Monad,+    module Control.Monad.Trans,+    -- * Example 1: Simple Continuation Usage+    -- $simpleContExample++    -- * Example 2: Using @callCC@+    -- $callCCExample+    +    -- * Example 3: Using @ContT@ Monad Transformer+    -- $ContTExample+  ) where++import Control.Monad.Cont.Class++import Control.Monad.Trans+import Control.Monad.Trans.Cont++import Control.Monad++{- $simpleContExample+Calculating length of a list continuation-style:++>calculateLength :: [a] -> Cont r Int+>calculateLength l = return (length l)++Here we use @calculateLength@ by making it to pass its result to @print@:++>main = do+>  runCont (calculateLength "123") print+>  -- result: 3++It is possible to chain 'Cont' blocks with @>>=@.++>double :: Int -> Cont r Int+>double n = return (n * 2)+>+>main = do+>  runCont (calculateLength "123" >>= double) print+>  -- result: 6+-}++{- $callCCExample+This example gives a taste of how escape continuations work, shows a typical+pattern for their usage.++>-- Returns a string depending on the length of the name parameter.+>-- If the provided string is empty, returns an error.+>-- Otherwise, returns a welcome message.+>whatsYourName :: String -> String+>whatsYourName name =+>  (`runCont` id) $ do                      -- 1+>    response <- callCC $ \exit -> do       -- 2+>      validateName name exit               -- 3+>      return $ "Welcome, " ++ name ++ "!"  -- 4+>    return response                        -- 5+>+>validateName name exit = do+>  when (null name) (exit "You forgot to tell me your name!")++Here is what this example does:++(1) Runs an anonymous 'Cont' block and extracts value from it with+@(\`runCont\` id)@. Here @id@ is the continuation, passed to the @Cont@ block.++(1) Binds @response@ to the result of the following 'Control.Monad.Cont.Class.callCC' block,+binds @exit@ to the continuation.++(1) Validates @name@.+This approach illustrates advantage of using 'Control.Monad.Cont.Class.callCC' over @return@.+We pass the continuation to @validateName@,+and interrupt execution of the @Cont@ block from /inside/ of @validateName@.++(1) Returns the welcome message from the 'Control.Monad.Cont.Class.callCC' block.+This line is not executed if @validateName@ fails.++(1) Returns from the @Cont@ block.+-}++{-$ContTExample+'ContT' can be used to add continuation handling to other monads.+Here is an example how to combine it with @IO@ monad:++>import Control.Monad.Cont+>import System.IO+>+>main = do+>  hSetBuffering stdout NoBuffering+>  runContT (callCC askString) reportResult+>+>askString :: (String -> ContT () IO String) -> ContT () IO String+>askString next = do+>  liftIO $ putStrLn "Please enter a string"+>  s <- liftIO $ getLine+>  next s+>+>reportResult :: String -> IO ()+>reportResult s = do+>  putStrLn ("You entered: " ++ s)++Action @askString@ requests user to enter a string,+and passes it to the continuation.+@askString@ takes as a parameter a continuation taking a string parameter,+and returning @IO ()@.+Compare its signature to 'runContT' definition.+-}
+ Control/Monad/Cont/Class.hs view
@@ -0,0 +1,130 @@+{- |+Module      :  Control.Monad.Cont.Class+Copyright   :  (c) The University of Glasgow 2001,+               (c) Jeff Newbern 2003-2007,+               (c) Andriy Palamarchuk 2007+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  portable++[Computation type:] Computations which can be interrupted and resumed.++[Binding strategy:] Binding a function to a monadic value creates+a new continuation which uses the function as the continuation of the monadic+computation.++[Useful for:] Complex control structures, error handling,+and creating co-routines.++[Zero and plus:] None.++[Example type:] @'Cont' r a@++The Continuation monad represents computations in continuation-passing style+(CPS).+In continuation-passing style function result is not returned,+but instead is passed to another function,+received as a parameter (continuation).+Computations are built up from sequences+of nested continuations, terminated by a final continuation (often @id@)+which produces the final result.+Since continuations are functions which represent the future of a computation,+manipulation of the continuation functions can achieve complex manipulations+of the future of the computation,+such as interrupting a computation in the middle, aborting a portion+of a computation, restarting a computation, and interleaving execution of+computations.+The Continuation monad adapts CPS to the structure of a monad.++Before using the Continuation monad, be sure that you have+a firm understanding of continuation-passing style+and that continuations represent the best solution to your particular+design problem.+Many algorithms which require continuations in other languages do not require+them in Haskell, due to Haskell's lazy semantics.+Abuse of the Continuation monad can produce code that is impossible+to understand and maintain.+-}++module Control.Monad.Cont.Class (+    MonadCont(..),+  ) where++import Control.Monad.Trans.Cont (ContT)+import qualified Control.Monad.Trans.Cont as ContT+import Control.Monad.Trans.Error as Error+import Control.Monad.Trans.Identity as Identity+import Control.Monad.Trans.List as List+import Control.Monad.Trans.Maybe as Maybe+import Control.Monad.Trans.Reader as Reader+import Control.Monad.Trans.RWS.Lazy as LazyRWS+import Control.Monad.Trans.RWS.Strict as StrictRWS+import Control.Monad.Trans.State.Lazy as LazyState+import Control.Monad.Trans.State.Strict as StrictState+import Control.Monad.Trans.Writer.Lazy as LazyWriter+import Control.Monad.Trans.Writer.Strict as StrictWriter++import Control.Monad+import Data.Monoid++class Monad m => MonadCont m where+    {- | @callCC@ (call-with-current-continuation)+    calls a function with the current continuation as its argument.+    Provides an escape continuation mechanism for use with Continuation monads.+    Escape continuations allow to abort the current computation and return+    a value immediately.+    They achieve a similar effect to 'Control.Monad.Error.throwError'+    and 'Control.Monad.Error.catchError'+    within an 'Control.Monad.Error.Error' monad.+    Advantage of this function over calling @return@ is that it makes+    the continuation explicit,+    allowing more flexibility and better control+    (see examples in "Control.Monad.Cont").++    The standard idiom used with @callCC@ is to provide a lambda-expression+    to name the continuation. Then calling the named continuation anywhere+    within its scope will escape from the computation,+    even if it is many layers deep within nested computations.+    -}+    callCC :: ((a -> m b) -> m a) -> m a++instance MonadCont (ContT r m) where+    callCC = ContT.callCC++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers++instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where+    callCC = Error.liftCallCC callCC++instance MonadCont m => MonadCont (IdentityT m) where+    callCC = Identity.liftCallCC callCC++instance MonadCont m => MonadCont (ListT m) where+    callCC = List.liftCallCC callCC++instance MonadCont m => MonadCont (MaybeT m) where+    callCC = Maybe.liftCallCC callCC++instance MonadCont m => MonadCont (ReaderT r m) where+    callCC = Reader.liftCallCC callCC++instance (Monoid w, MonadCont m) => MonadCont (LazyRWS.RWST r w s m) where+    callCC = LazyRWS.liftCallCC' callCC++instance (Monoid w, MonadCont m) => MonadCont (StrictRWS.RWST r w s m) where+    callCC = StrictRWS.liftCallCC' callCC++instance MonadCont m => MonadCont (LazyState.StateT s m) where+    callCC = LazyState.liftCallCC' callCC++instance MonadCont m => MonadCont (StrictState.StateT s m) where+    callCC = StrictState.liftCallCC' callCC++instance (Monoid w, MonadCont m) => MonadCont (LazyWriter.WriterT w m) where+    callCC = LazyWriter.liftCallCC callCC++instance (Monoid w, MonadCont m) => MonadCont (StrictWriter.WriterT w m) where+    callCC = StrictWriter.liftCallCC callCC
+ Control/Monad/Error.hs view
@@ -0,0 +1,145 @@+{- |+Module      :  Control.Monad.Error+Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,+               (c) Jeff Newbern 2003-2006,+               (c) Andriy Palamarchuk 2006+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  non-portable (multi-parameter type classes)++[Computation type:] Computations which may fail or throw exceptions.++[Binding strategy:] Failure records information about the cause\/location+of the failure. Failure values bypass the bound function,+other values are used as inputs to the bound function.++[Useful for:] Building computations from sequences of functions that may fail+or using exception handling to structure error handling.++[Zero and plus:] Zero is represented by an empty error and the plus operation+executes its second argument if the first fails.++[Example type:] @'Data.Either' String a@++The Error monad (also called the Exception monad).+-}++{-+  Rendered by Michael Weber <mailto:michael.weber@post.rwth-aachen.de>,+  inspired by the Haskell Monad Template Library from+    Andy Gill (<http://web.cecs.pdx.edu/~andy/>)+-}+module Control.Monad.Error (+    -- * Monads with error handling+    MonadError(..),+    Error(..),+    -- * The ErrorT monad transformer+    ErrorT(..),+    mapErrorT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    -- * Example 1: Custom Error Data Type+    -- $customErrorExample++    -- * Example 2: Using ErrorT Monad Transformer+    -- $ErrorTExample+  ) where++import Control.Monad.Error.Class+import Control.Monad.Trans+import Control.Monad.Trans.Error (ErrorT(..), mapErrorT)++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Instances ()++{- $customErrorExample+Here is an example that demonstrates the use of a custom 'Error' data type with+the 'throwError' and 'catchError' exception mechanism from 'MonadError'.+The example throws an exception if the user enters an empty string+or a string longer than 5 characters. Otherwise it prints length of the string.++>-- This is the type to represent length calculation error.+>data LengthError = EmptyString  -- Entered string was empty.+>          | StringTooLong Int   -- A string is longer than 5 characters.+>                                -- Records a length of the string.+>          | OtherError String   -- Other error, stores the problem description.+>+>-- We make LengthError an instance of the Error class+>-- to be able to throw it as an exception.+>instance Error LengthError where+>  noMsg    = OtherError "A String Error!"+>  strMsg s = OtherError s+>+>-- Converts LengthError to a readable message.+>instance Show LengthError where+>  show EmptyString = "The string was empty!"+>  show (StringTooLong len) =+>      "The length of the string (" ++ (show len) ++ ") is bigger than 5!"+>  show (OtherError msg) = msg+>+>-- For our monad type constructor, we use Either LengthError+>-- which represents failure using Left LengthError+>-- or a successful result of type a using Right a.+>type LengthMonad = Either LengthError+>+>main = do+>  putStrLn "Please enter a string:"+>  s <- getLine+>  reportResult (calculateLength s)+>+>-- Wraps length calculation to catch the errors.+>-- Returns either length of the string or an error.+>calculateLength :: String -> LengthMonad Int+>calculateLength s = (calculateLengthOrFail s) `catchError` Left+>+>-- Attempts to calculate length and throws an error if the provided string is+>-- empty or longer than 5 characters.+>-- The processing is done in Either monad.+>calculateLengthOrFail :: String -> LengthMonad Int+>calculateLengthOrFail [] = throwError EmptyString+>calculateLengthOrFail s | len > 5 = throwError (StringTooLong len)+>                        | otherwise = return len+>  where len = length s+>+>-- Prints result of the string length calculation.+>reportResult :: LengthMonad Int -> IO ()+>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len))+>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e))+-}++{- $ErrorTExample+@'ErrorT'@ monad transformer can be used to add error handling to another monad.+Here is an example how to combine it with an @IO@ monad:++>import Control.Monad.Error+>+>-- An IO monad which can return String failure.+>-- It is convenient to define the monad type of the combined monad,+>-- especially if we combine more monad transformers.+>type LengthMonad = ErrorT String IO+>+>main = do+>  -- runErrorT removes the ErrorT wrapper+>  r <- runErrorT calculateLength+>  reportResult r+>+>-- Asks user for a non-empty string and returns its length.+>-- Throws an error if user enters an empty string.+>calculateLength :: LengthMonad Int+>calculateLength = do+>  -- all the IO operations have to be lifted to the IO monad in the monad stack+>  liftIO $ putStrLn "Please enter a non-empty string: "+>  s <- liftIO getLine+>  if null s+>    then throwError "The string was empty!"+>    else return $ length s+>+>-- Prints result of the string length calculation.+>reportResult :: Either String Int -> IO ()+>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len))+>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e))+-}
+ Control/Monad/Error/Class.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Control.Monad.Error.Class+Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,+               (c) Jeff Newbern 2003-2006,+               (c) Andriy Palamarchuk 2006+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  non-portable (multi-parameter type classes)++[Computation type:] Computations which may fail or throw exceptions.++[Binding strategy:] Failure records information about the cause\/location+of the failure. Failure values bypass the bound function,+other values are used as inputs to the bound function.++[Useful for:] Building computations from sequences of functions that may fail+or using exception handling to structure error handling.++[Zero and plus:] Zero is represented by an empty error and the plus operation+executes its second argument if the first fails.++[Example type:] @'Either' 'String' a@++The Error monad (also called the Exception monad).+-}++{-+  Rendered by Michael Weber <mailto:michael.weber@post.rwth-aachen.de>,+  inspired by the Haskell Monad Template Library from+    Andy Gill (<http://web.cecs.pdx.edu/~andy/>)+-}+module Control.Monad.Error.Class (+    Error(..),+    MonadError(..),+  ) where++import Control.Monad.Trans.Error (Error(..), ErrorT)+import qualified Control.Monad.Trans.Error as ErrorT (throwError, catchError)+import Control.Monad.Trans.Identity as Identity+import Control.Monad.Trans.List as List+import Control.Monad.Trans.Maybe as Maybe+import Control.Monad.Trans.Reader as Reader+import Control.Monad.Trans.RWS.Lazy as LazyRWS+import Control.Monad.Trans.RWS.Strict as StrictRWS+import Control.Monad.Trans.State.Lazy as LazyState+import Control.Monad.Trans.State.Strict as StrictState+import Control.Monad.Trans.Writer.Lazy as LazyWriter+import Control.Monad.Trans.Writer.Strict as StrictWriter++import Control.Monad.Trans.Class (lift)+import Control.Exception (IOException)+import Control.Monad+import Control.Monad.Instances ()+import Data.Monoid++{- |+The strategy of combining computations that can throw exceptions+by bypassing bound functions+from the point an exception is thrown to the point that it is handled.++Is parameterized over the type of error information and+the monad type constructor.+It is common to use @'Data.Either' String@ as the monad type constructor+for an error monad in which error descriptions take the form of strings.+In that case and many other common cases the resulting monad is already defined+as an instance of the 'MonadError' class.+You can also define your own error type and\/or use a monad type constructor+other than @'Either' 'String'@ or @'Either' 'IOError'@.+In these cases you will have to explicitly define instances of the 'Error'+and\/or 'MonadError' classes.+-}+class (Monad m) => MonadError e m | m -> e where+    -- | Is used within a monadic computation to begin exception processing.+    throwError :: e -> m a++    {- |+    A handler function to handle previous errors and return to normal execution.+    A common idiom is:++    > do { action1; action2; action3 } `catchError` handler++    where the @action@ functions can call 'throwError'.+    Note that @handler@ and the do-block must have the same return type.+    -}+    catchError :: m a -> (e -> m a) -> m a++instance MonadError IOException IO where+    throwError = ioError+    catchError = catch++-- ---------------------------------------------------------------------------+-- Our parameterizable error monad++instance Error e => MonadError e (Either e) where+    throwError             = Left+    Left  l `catchError` h = h l+    Right r `catchError` _ = Right r++instance (Monad m, Error e) => MonadError e (ErrorT e m) where+    throwError = ErrorT.throwError+    catchError = ErrorT.catchError++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance MonadError e m => MonadError e (IdentityT m) where+    throwError = lift . throwError+    catchError = Identity.liftCatch catchError++instance MonadError e m => MonadError e (ListT m) where+    throwError = lift . throwError+    catchError = List.liftCatch catchError++instance MonadError e m => MonadError e (MaybeT m) where+    throwError = lift . throwError+    catchError = Maybe.liftCatch catchError++instance MonadError e m => MonadError e (ReaderT r m) where+    throwError = lift . throwError+    catchError = Reader.liftCatch catchError++instance (Monoid w, MonadError e m) => MonadError e (LazyRWS.RWST r w s m) where+    throwError = lift . throwError+    catchError = LazyRWS.liftCatch catchError++instance (Monoid w, MonadError e m) => MonadError e (StrictRWS.RWST r w s m) where+    throwError = lift . throwError+    catchError = StrictRWS.liftCatch catchError++instance MonadError e m => MonadError e (LazyState.StateT s m) where+    throwError = lift . throwError+    catchError = LazyState.liftCatch catchError++instance MonadError e m => MonadError e (StrictState.StateT s m) where+    throwError = lift . throwError+    catchError = StrictState.liftCatch catchError++instance (Monoid w, MonadError e m) => MonadError e (LazyWriter.WriterT w m) where+    throwError = lift . throwError+    catchError = LazyWriter.liftCatch catchError++instance (Monoid w, MonadError e m) => MonadError e (StrictWriter.WriterT w m) where+    throwError = lift . throwError+    catchError = StrictWriter.liftCatch catchError
+ Control/Monad/IO/Class.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.IO.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Class of monads based on @IO@.+-----------------------------------------------------------------------------++module Control.Monad.IO.Class (+    MonadIO(..)+  ) where++import System.IO (IO)++-- | Monads in which 'IO' computations may be embedded.+-- Any monad built by applying a sequence of monad transformers to the+-- 'IO' monad will be an instance of this class.+--+-- Instances should satisfy the following laws, which state that 'liftIO'+-- is a transformer of monads:+--+-- * @'liftIO' . 'return' = 'return'@+--+-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@++class (Monad m) => MonadIO m where+    -- | Lift a computation from the 'IO' monad.+    liftIO :: IO a -> m a++instance MonadIO IO where+    liftIO = id
+ Control/Monad/Identity.hs view
@@ -0,0 +1,44 @@+{- |+Module      :  Control.Monad.Identity+Copyright   :  (c) Andy Gill 2001,+               (c) Oregon Graduate Institute of Science and Technology 2001,+               (c) Jeff Newbern 2003-2006,+               (c) Andriy Palamarchuk 2006+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  portable++[Computation type:] Simple function application.++[Binding strategy:] The bound function is applied to the input value.+@'Identity' x >>= f == 'Identity' (f x)@++[Useful for:] Monads can be derived from monad transformers applied to the+'Identity' monad.++[Zero and plus:] None.++[Example type:] @'Identity' a@++The @Identity@ monad is a monad that does not embody any computational strategy.+It simply applies the bound function to its input without any modification.+Computationally, there is no reason to use the @Identity@ monad+instead of the much simpler act of simply applying functions to their arguments.+The purpose of the @Identity@ monad is its fundamental role in the theory+of monad transformers.+Any monad transformer applied to the @Identity@ monad yields a non-transformer+version of that monad.+-}++module Control.Monad.Identity (+    module Data.Functor.Identity,++    module Control.Monad,+    module Control.Monad.Fix,+   ) where++import Control.Monad+import Control.Monad.Fix+import Data.Functor.Identity
+ Control/Monad/List.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.List+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The List monad.+--+-----------------------------------------------------------------------------++module Control.Monad.List (+    ListT(..),+    mapListT,+    module Control.Monad,+    module Control.Monad.Trans,+  ) where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.List
+ Control/Monad/RWS.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.RWS+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Declaration of the MonadRWS class.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.RWS (+    module Control.Monad.RWS.Lazy+  ) where+ +import Control.Monad.RWS.Lazy
+ Control/Monad/RWS/Class.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE UndecidableInstances #-}+-- Search for UndecidableInstances to see why this is needed++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.RWS.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Declaration of the MonadRWS class.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.RWS.Class (+    MonadRWS,+    module Control.Monad.Reader.Class,+    module Control.Monad.State.Class,+    module Control.Monad.Writer.Class,+  ) where++import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Writer.Class++import Control.Monad.Trans.Class+import Control.Monad.Trans.Error(Error, ErrorT)+import Control.Monad.Trans.Maybe(MaybeT)+import Control.Monad.Trans.Identity(IdentityT)+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)++import Data.Monoid++class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m)+   => MonadRWS r w s m | m -> r, m -> w, m -> s++instance (Monoid w, Monad m) => MonadRWS r w s (Lazy.RWST r w s m)++instance (Monoid w, Monad m) => MonadRWS r w s (Strict.RWST r w s m)+ +---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance (Error e, MonadRWS r w s m) => MonadRWS r w s (ErrorT e m)+instance MonadRWS r w s m => MonadRWS r w s (IdentityT m)+instance MonadRWS r w s m => MonadRWS r w s (MaybeT m)
+ Control/Monad/RWS/Lazy.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.RWS.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Lazy RWS monad.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.RWS.Lazy (+    -- * The RWS monad+    RWS,+    rws,+    runRWS,+    evalRWS,+    execRWS,+    mapRWS,+    withRWS,+    -- * The RWST monad transformer+    RWST(..),+    evalRWST,+    execRWST,+    mapRWST,+    withRWST,+    -- * Lazy Reader-writer-state monads+    module Control.Monad.RWS.Class,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    module Data.Monoid,+  ) where++import Control.Monad.RWS.Class++import Control.Monad.Trans+import Control.Monad.Trans.RWS.Lazy (+    RWS, rws, runRWS, evalRWS, execRWS, mapRWS, withRWS,+    RWST(..), evalRWST, execRWST, mapRWST, withRWST)++import Control.Monad+import Control.Monad.Fix+import Data.Monoid
+ Control/Monad/RWS/Strict.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.RWS.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Strict RWS monad.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.RWS.Strict (+    -- * The RWS monad+    RWS,+    rws,+    runRWS,+    evalRWS,+    execRWS,+    mapRWS,+    withRWS,+    -- * The RWST monad transformer+    RWST(..),+    evalRWST,+    execRWST,+    mapRWST,+    withRWST,+    -- * Strict Reader-writer-state monads+    module Control.Monad.RWS.Class,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    module Data.Monoid,+  ) where++import Control.Monad.RWS.Class++import Control.Monad.Trans+import Control.Monad.Trans.RWS.Strict (+    RWS, rws, runRWS, evalRWS, execRWS, mapRWS, withRWS,+    RWST(..), evalRWST, execRWST, mapRWST, withRWST)++import Control.Monad+import Control.Monad.Fix+import Data.Monoid
+ Control/Monad/Reader.hs view
@@ -0,0 +1,143 @@+{- |+Module      :  Control.Monad.Reader+Copyright   :  (c) Andy Gill 2001,+               (c) Oregon Graduate Institute of Science and Technology 2001,+               (c) Jeff Newbern 2003-2007,+               (c) Andriy Palamarchuk 2007+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  non-portable (multi-param classes, functional dependencies)++[Computation type:] Computations which read values from a shared environment.++[Binding strategy:] Monad values are functions from the environment to a value.+The bound function is applied to the bound value, and both have access+to the shared environment.++[Useful for:] Maintaining variable bindings, or other shared environment.++[Zero and plus:] None.++[Example type:] @'Reader' [(String,Value)] a@++The 'Reader' monad (also called the Environment monad).+Represents a computation, which can read values from+a shared environment, pass values from function to function,+and execute sub-computations in a modified environment.+Using 'Reader' monad for such computations is often clearer and easier+than using the 'Control.Monad.State.State' monad.++  Inspired by the paper+  /Functional Programming with Overloading and Higher-Order Polymorphism/,+    Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+    Advanced School of Functional Programming, 1995.+-}++module Control.Monad.Reader (+    -- * MonadReader class+    MonadReader(..),+    asks,+    -- * The Reader monad+    Reader,+    runReader,+    mapReader,+    withReader,+    -- * The ReaderT monad transformer+    ReaderT(..),+    mapReaderT,+    withReaderT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    -- * Example 1: Simple Reader Usage+    -- $simpleReaderExample++    -- * Example 2: Modifying Reader Content With @local@+    -- $localExample++    -- * Example 3: @ReaderT@ Monad Transformer+    -- $ReaderTExample+    ) where++import Control.Monad.Reader.Class++import Control.Monad.Trans.Reader (+    Reader, runReader, mapReader, withReader,+    ReaderT(..), mapReaderT, withReaderT)+import Control.Monad.Trans++import Control.Monad+import Control.Monad.Fix++{- $simpleReaderExample++In this example the @Reader@ monad provides access to variable bindings.+Bindings are a @Map@ of integer variables.+The variable @count@ contains number of variables in the bindings.+You can see how to run a Reader monad and retrieve data from it+with 'runReader', how to access the Reader data with 'ask' and 'asks'.++> type Bindings = Map String Int;+>+>-- Returns True if the "count" variable contains correct bindings size.+>isCountCorrect :: Bindings -> Bool+>isCountCorrect bindings = runReader calc_isCountCorrect bindings+>+>-- The Reader monad, which implements this complicated check.+>calc_isCountCorrect :: Reader Bindings Bool+>calc_isCountCorrect = do+>    count <- asks (lookupVar "count")+>    bindings <- ask+>    return (count == (Map.size bindings))+>+>-- The selector function to  use with 'asks'.+>-- Returns value of the variable with specified name.+>lookupVar :: String -> Bindings -> Int+>lookupVar name bindings = fromJust (Map.lookup name bindings)+>+>sampleBindings = Map.fromList [("count",3), ("1",1), ("b",2)]+>+>main = do+>    putStr $ "Count is correct for bindings " ++ (show sampleBindings) ++ ": ";+>    putStrLn $ show (isCountCorrect sampleBindings);+-}++{- $localExample++Shows how to modify Reader content with 'local'.++>calculateContentLen :: Reader String Int+>calculateContentLen = do+>    content <- ask+>    return (length content);+>+>-- Calls calculateContentLen after adding a prefix to the Reader content.+>calculateModifiedContentLen :: Reader String Int+>calculateModifiedContentLen = local ("Prefix " ++) calculateContentLen+>+>main = do+>    let s = "12345";+>    let modifiedLen = runReader calculateModifiedContentLen s+>    let len = runReader calculateContentLen s+>    putStrLn $ "Modified 's' length: " ++ (show modifiedLen)+>    putStrLn $ "Original 's' length: " ++ (show len)+-}++{- $ReaderTExample++Now you are thinking: 'Wow, what a great monad! I wish I could use+Reader functionality in MyFavoriteComplexMonad!'. Don't worry.+This can be easy done with the 'ReaderT' monad transformer.+This example shows how to combine @ReaderT@ with the IO monad.++>-- The Reader/IO combined monad, where Reader stores a string.+>printReaderContent :: ReaderT String IO ()+>printReaderContent = do+>    content <- ask+>    liftIO $ putStrLn ("The Reader Content: " ++ content)+>+>main = do+>    runReaderT printReaderContent "Some Content"+-}
+ Control/Monad/Reader/Class.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE UndecidableInstances #-}+-- Search for UndecidableInstances to see why this is needed+{- |+Module      :  Control.Monad.Reader.Class+Copyright   :  (c) Andy Gill 2001,+               (c) Oregon Graduate Institute of Science and Technology 2001,+               (c) Jeff Newbern 2003-2007,+               (c) Andriy Palamarchuk 2007+License     :  BSD-style (see the file LICENSE)++Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  non-portable (multi-param classes, functional dependencies)++[Computation type:] Computations which read values from a shared environment.++[Binding strategy:] Monad values are functions from the environment to a value.+The bound function is applied to the bound value, and both have access+to the shared environment.++[Useful for:] Maintaining variable bindings, or other shared environment.++[Zero and plus:] None.++[Example type:] @'Reader' [(String,Value)] a@++The 'Reader' monad (also called the Environment monad).+Represents a computation, which can read values from+a shared environment, pass values from function to function,+and execute sub-computations in a modified environment.+Using 'Reader' monad for such computations is often clearer and easier+than using the 'Control.Monad.State.State' monad.++  Inspired by the paper+  /Functional Programming with Overloading and Higher-Order Polymorphism/,+    Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+    Advanced School of Functional Programming, 1995.+-}++module Control.Monad.Reader.Class (+    MonadReader(..),+    asks,+    ) where++import Control.Monad.Trans.Cont as Cont+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.Reader as ReaderT (ask, local, reader)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, ask, local, reader)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, ask, local, reader)+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict++import Control.Monad.Trans.Class (lift)+import Control.Monad+import Data.Monoid++-- ----------------------------------------------------------------------------+-- class MonadReader+--  asks for the internal (non-mutable) state.++-- | See examples in "Control.Monad.Reader".+-- Note, the partially applied function type @(->) r@ is a simple reader monad.+-- See the @instance@ declaration below.+class Monad m => MonadReader r m | m -> r where+    -- | Retrieves the monad environment.+    ask   :: m r++    -- | Executes a computation in a modified environment.+    local :: (r -> r) -- ^ The function to modify the environment.+          -> m a      -- ^ @Reader@ to run in the modified environment.+          -> m a++    -- | Retrieves a function of the current environment.+    reader :: (r -> a) -- ^ The selector function to apply to the environment.+           -> m a+    reader f = do+      r <- ask+      return (f r)++-- | Retrieves a function of the current environment.+asks :: MonadReader r m+    => (r -> a) -- ^ The selector function to apply to the environment.+    -> m a+asks = reader++-- ----------------------------------------------------------------------------+-- The partially applied function type is a simple reader monad++instance MonadReader r ((->) r) where+    ask       = id+    local f m = m . f+    reader    = id++instance Monad m => MonadReader r (ReaderT r m) where+    ask = ReaderT.ask+    local = ReaderT.local+    reader = ReaderT.reader++instance (Monad m, Monoid w) => MonadReader r (LazyRWS.RWST r w s m) where+    ask = LazyRWS.ask+    local = LazyRWS.local+    reader = LazyRWS.reader++instance (Monad m, Monoid w) => MonadReader r (StrictRWS.RWST r w s m) where+    ask = StrictRWS.ask+    local = StrictRWS.local+    reader = StrictRWS.reader++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance MonadReader r' m => MonadReader r' (ContT r m) where+    ask   = lift ask+    local = Cont.liftLocal ask local+    reader = lift . reader++instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where+    ask   = lift ask+    local = mapErrorT . local+    reader = lift . reader++instance MonadReader r m => MonadReader r (IdentityT m) where+    ask   = lift ask+    local = mapIdentityT . local+    reader = lift . reader++instance MonadReader r m => MonadReader r (ListT m) where+    ask   = lift ask+    local = mapListT . local+    reader = lift . reader++instance MonadReader r m => MonadReader r (MaybeT m) where+    ask   = lift ask+    local = mapMaybeT . local+    reader = lift . reader++instance MonadReader r m => MonadReader r (Lazy.StateT s m) where+    ask   = lift ask+    local = Lazy.mapStateT . local+    reader = lift . reader++instance MonadReader r m => MonadReader r (Strict.StateT s m) where+    ask   = lift ask+    local = Strict.mapStateT . local+    reader = lift . reader++instance (Monoid w, MonadReader r m) => MonadReader r (Lazy.WriterT w m) where+    ask   = lift ask+    local = Lazy.mapWriterT . local+    reader = lift . reader++instance (Monoid w, MonadReader r m) => MonadReader r (Strict.WriterT w m) where+    ask   = lift ask+    local = Strict.mapWriterT . local+    reader = lift . reader
+ Control/Monad/State.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.State+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- State monads.+--+--      This module is inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.++-----------------------------------------------------------------------------++module Control.Monad.State (+  module Control.Monad.State.Lazy+  ) where++import Control.Monad.State.Lazy
+ Control/Monad/State/Class.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE UndecidableInstances #-}+-- Search for UndecidableInstances to see why this is needed++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.State.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- MonadState class.+--+--      This module is inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.++-----------------------------------------------------------------------------++module Control.Monad.State.Class (+    MonadState(..),+    modify,+    gets,+  ) where++import Control.Monad.Trans.Cont+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, get, put, state)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, get, put, state)+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT, get, put, state)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, get, put, state)+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict++import Control.Monad.Trans.Class (lift)+import Control.Monad+import Data.Monoid++-- ---------------------------------------------------------------------------++-- | Minimal definition is either both of @get@ and @put@ or just @state@+class Monad m => MonadState s m | m -> s where+    -- | Return the state from the internals of the monad.+    get :: m s+    get = state (\s -> (s, s))++    -- | Replace the state inside the monad.+    put :: s -> m ()+    put s = state (\_ -> ((), s))++    -- | Embed a simple state action into the monad.+    state :: (s -> (a, s)) -> m a+    state f = do+      s <- get+      let ~(a, s') = f s+      put s'+      return a++-- | Monadic state transformer.+--+--      Maps an old state to a new state inside a state monad.+--      The old state is thrown away.+--+-- >      Main> :t modify ((+1) :: Int -> Int)+-- >      modify (...) :: (MonadState Int a) => a ()+--+--    This says that @modify (+1)@ acts over any+--    Monad that is a member of the @MonadState@ class,+--    with an @Int@ state.+modify :: MonadState s m => (s -> s) -> m ()+modify f = state (\s -> ((), f s))++-- | Gets specific component of the state, using a projection function+-- supplied.+gets :: MonadState s m => (s -> a) -> m a+gets f = do+    s <- get+    return (f s)++instance Monad m => MonadState s (Lazy.StateT s m) where+    get = Lazy.get+    put = Lazy.put+    state = Lazy.state++instance Monad m => MonadState s (Strict.StateT s m) where+    get = Strict.get+    put = Strict.put+    state = Strict.state++instance (Monad m, Monoid w) => MonadState s (LazyRWS.RWST r w s m) where+    get = LazyRWS.get+    put = LazyRWS.put+    state = LazyRWS.state++instance (Monad m, Monoid w) => MonadState s (StrictRWS.RWST r w s m) where+    get = StrictRWS.get+    put = StrictRWS.put+    state = StrictRWS.state++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance MonadState s m => MonadState s (ContT r m) where+    get = lift get+    put = lift . put+    state = lift . state++instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where+    get = lift get+    put = lift . put+    state = lift . state++instance MonadState s m => MonadState s (IdentityT m) where+    get = lift get+    put = lift . put+    state = lift . state++instance MonadState s m => MonadState s (ListT m) where+    get = lift get+    put = lift . put+    state = lift . state++instance MonadState s m => MonadState s (MaybeT m) where+    get = lift get+    put = lift . put+    state = lift . state++instance MonadState s m => MonadState s (ReaderT r m) where+    get = lift get+    put = lift . put+    state = lift . state++instance (Monoid w, MonadState s m) => MonadState s (Lazy.WriterT w m) where+    get = lift get+    put = lift . put+    state = lift . state++instance (Monoid w, MonadState s m) => MonadState s (Strict.WriterT w m) where+    get = lift get+    put = lift . put+    state = lift . state
+ Control/Monad/State/Lazy.hs view
@@ -0,0 +1,128 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.State.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Lazy state monads.+--+--      This module is inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.++-----------------------------------------------------------------------------++module Control.Monad.State.Lazy (+    -- * MonadState class+    MonadState(..),+    modify,+    gets,+    -- * The State monad+    State,+    runState,+    evalState,+    execState,+    mapState,+    withState,+    -- * The StateT monad transformer+    StateT(..),+    evalStateT,+    execStateT,+    mapStateT,+    withStateT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    -- * Examples+    -- $examples+  ) where++import Control.Monad.State.Class++import Control.Monad.Trans+import Control.Monad.Trans.State.Lazy+        (State, runState, evalState, execState, mapState, withState,+         StateT(..), evalStateT, execStateT, mapStateT, withStateT)++import Control.Monad+import Control.Monad.Fix++-- ---------------------------------------------------------------------------+-- $examples+-- A function to increment a counter.  Taken from the paper+-- /Generalising Monads to Arrows/, John+-- Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:+--+-- > tick :: State Int Int+-- > tick = do n <- get+-- >           put (n+1)+-- >           return n+--+-- Add one to the given number using the state monad:+--+-- > plusOne :: Int -> Int+-- > plusOne n = execState tick n+--+-- A contrived addition example. Works only with positive numbers:+--+-- > plus :: Int -> Int -> Int+-- > plus n x = execState (sequence $ replicate n tick) x+--+-- An example from /The Craft of Functional Programming/, Simon+-- Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),+-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a+-- tree of integers in which the original elements are replaced by+-- natural numbers, starting from 0.  The same element has to be+-- replaced by the same number at every occurrence, and when we meet+-- an as-yet-unvisited element we have to find a \'new\' number to match+-- it with:\"+--+-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)+-- > type Table a = [a]+--+-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)+-- > numberTree Nil = return Nil+-- > numberTree (Node x t1 t2)+-- >        =  do num <- numberNode x+-- >              nt1 <- numberTree t1+-- >              nt2 <- numberTree t2+-- >              return (Node num nt1 nt2)+-- >     where+-- >     numberNode :: Eq a => a -> State (Table a) Int+-- >     numberNode x+-- >        = do table <- get+-- >             (newTable, newPos) <- return (nNode x table)+-- >             put newTable+-- >             return newPos+-- >     nNode::  (Eq a) => a -> Table a -> (Table a, Int)+-- >     nNode x table+-- >        = case (findIndexInList (== x) table) of+-- >          Nothing -> (table ++ [x], length table)+-- >          Just i  -> (table, i)+-- >     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int+-- >     findIndexInList = findIndexInListHelp 0+-- >     findIndexInListHelp _ _ [] = Nothing+-- >     findIndexInListHelp count f (h:t)+-- >        = if (f h)+-- >          then Just count+-- >          else findIndexInListHelp (count+1) f t+--+-- numTree applies numberTree with an initial state:+--+-- > numTree :: (Eq a) => Tree a -> Tree Int+-- > numTree t = evalState (numberTree t) []+--+-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil+-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil+--+-- sumTree is a little helper function that does not use the State monad:+--+-- > sumTree :: (Num a) => Tree a -> a+-- > sumTree Nil = 0+-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)
+ Control/Monad/State/Strict.hs view
@@ -0,0 +1,128 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.State.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Strict state monads.+--+--      This module is inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)+--          Advanced School of Functional Programming, 1995.++-----------------------------------------------------------------------------++module Control.Monad.State.Strict (+    -- * MonadState class+    MonadState(..),+    modify,+    gets,+    -- * The State monad+    State,+    runState,+    evalState,+    execState,+    mapState,+    withState,+    -- * The StateT monad transformer+    StateT(..),+    evalStateT,+    execStateT,+    mapStateT,+    withStateT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    -- * Examples+    -- $examples+  ) where++import Control.Monad.State.Class++import Control.Monad.Trans+import Control.Monad.Trans.State.Strict+        (State, runState, evalState, execState, mapState, withState,+         StateT(..), evalStateT, execStateT, mapStateT, withStateT)++import Control.Monad+import Control.Monad.Fix++-- ---------------------------------------------------------------------------+-- $examples+-- A function to increment a counter.  Taken from the paper+-- /Generalising Monads to Arrows/, John+-- Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:+--+-- > tick :: State Int Int+-- > tick = do n <- get+-- >           put (n+1)+-- >           return n+--+-- Add one to the given number using the state monad:+--+-- > plusOne :: Int -> Int+-- > plusOne n = execState tick n+--+-- A contrived addition example. Works only with positive numbers:+--+-- > plus :: Int -> Int -> Int+-- > plus n x = execState (sequence $ replicate n tick) x+--+-- An example from /The Craft of Functional Programming/, Simon+-- Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),+-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a+-- tree of integers in which the original elements are replaced by+-- natural numbers, starting from 0.  The same element has to be+-- replaced by the same number at every occurrence, and when we meet+-- an as-yet-unvisited element we have to find a \'new\' number to match+-- it with:\"+--+-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)+-- > type Table a = [a]+--+-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)+-- > numberTree Nil = return Nil+-- > numberTree (Node x t1 t2)+-- >        =  do num <- numberNode x+-- >              nt1 <- numberTree t1+-- >              nt2 <- numberTree t2+-- >              return (Node num nt1 nt2)+-- >     where+-- >     numberNode :: Eq a => a -> State (Table a) Int+-- >     numberNode x+-- >        = do table <- get+-- >             (newTable, newPos) <- return (nNode x table)+-- >             put newTable+-- >             return newPos+-- >     nNode::  (Eq a) => a -> Table a -> (Table a, Int)+-- >     nNode x table+-- >        = case (findIndexInList (== x) table) of+-- >          Nothing -> (table ++ [x], length table)+-- >          Just i  -> (table, i)+-- >     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int+-- >     findIndexInList = findIndexInListHelp 0+-- >     findIndexInListHelp _ _ [] = Nothing+-- >     findIndexInListHelp count f (h:t)+-- >        = if (f h)+-- >          then Just count+-- >          else findIndexInListHelp (count+1) f t+--+-- numTree applies numberTree with an initial state:+--+-- > numTree :: (Eq a) => Tree a -> Tree Int+-- > numTree t = evalState (numberTree t) []+--+-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil+-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil+--+-- sumTree is a little helper function that does not use the State monad:+--+-- > sumTree :: (Num a) => Tree a -> a+-- > sumTree Nil = 0+-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)
+ Control/Monad/Trans.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Classes for monad transformers.+--+-- A monad transformer makes new monad out of an existing monad, such+-- that computations of the old monad may be embedded in the new one.+-- To construct a monad with a desired set of features, one typically+-- starts with a base monad, such as @Identity@, @[]@ or 'IO', and+-- applies a sequence of monad transformers.+--+-- Most monad transformer modules include the special case of applying the+-- transformer to @Identity@.  For example, @State s@ is an abbreviation+-- for @StateT s Identity@.+--+-- Each monad transformer also comes with an operation @run@/XXX/ to+-- unwrap the transformer, exposing a computation of the inner monad.+-----------------------------------------------------------------------------++module Control.Monad.Trans (+    module Control.Monad.Trans.Class,+    module Control.Monad.IO.Class+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class
+ Control/Monad/Trans/Class.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Classes for monad transformers.+--+-- A monad transformer makes a new monad out of an existing monad, such+-- that computations of the old monad may be embedded in the new one.+-- To construct a monad with a desired set of features, one typically+-- starts with a base monad, such as @Identity@, @[]@ or 'IO', and+-- applies a sequence of monad transformers.+--+-- Most monad transformer modules include the special case of applying the+-- transformer to @Identity@.  For example, @State s@ is an abbreviation+-- for @StateT s Identity@.+--+-- Each monad transformer also comes with an operation @run@/XXX/ to+-- unwrap the transformer, exposing a computation of the inner monad.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Class (+    -- * Transformer class+    MonadTrans(..)++    -- * Examples+    -- ** Parsing+    -- $example1++    -- ** Parsing and counting+    -- $example2+  ) where++-- | The class of monad transformers.  Instances should satisfy the+-- following laws, which state that 'lift' is a transformer of monads:+--+-- * @'lift' . 'return' = 'return'@+--+-- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@++class MonadTrans t where+    -- | Lift a computation from the argument monad to the constructed monad.+    lift :: Monad m => m a -> t m a++{- $example1++One might define a parsing monad by adding a state (the 'String' remaining+to be parsed) to the @[]@ monad, which provides non-determinism:++> import Control.Monad.Trans.State+>+> type Parser = StateT String []++Then @Parser@ is an instance of @MonadPlus@: monadic sequencing implements+concatenation of parsers, while @mplus@ provides choice.+To use parsers, we need a primitive to run a constructed parser on an+input string:++> runParser :: Parser a -> String -> [a]+> runParser p s = [x | (x, "") <- runStateT p s]++Finally, we need a primitive parser that matches a single character,+from which arbitrarily complex parsers may be constructed:++> item :: Parser Char+> item = do+>     c:cs <- get+>     put cs+>     return c++In this example we use the operations @get@ and @put@ from+"Control.Monad.Trans.State", which are defined only for monads that are+applications of @StateT@.  Alternatively one could use monad classes+from the @mtl@ package or similar, which contain methods @get@ and @put@+with types generalized over all suitable monads.+-}++{- $example2++We can define a parser that also counts by adding a @WriterT@ transformer:++> import Control.Monad.Trans.Class+> import Control.Monad.Trans.State+> import Control.Monad.Trans.Writer+> import Data.Monoid+>+> type Parser = WriterT (Sum Int) (StateT String [])++The function that applies a parser must now unwrap each of the monad+transformers in turn:++> runParser :: Parser a -> String -> [(a, Int)]+> runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s]++To define @item@ parser, we need to lift the @StateT@ operations through+the @WriterT@ transformers.++> item :: Parser Char+> item = do+>     c:cs <- lift get+>     lift (put cs)+>     return c++In this case, we were able to do this with 'lift', but operations with+more complex types require special lifting functions, which are provided+by monad transformers for which they can be implemented.  If you use the+monad classes of the @mtl@ package or similar, this lifting is handled+automatically by the instances of the classes, and you need only use+the generalized methods @get@ and @put@.++We can also define a primitive using the Writer:++> tick :: Parser ()+> tick = tell (Sum 1)++Then the parser will keep track of how many @tick@s it executes.+-}
+ Control/Monad/Trans/Cont.hs view
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Cont+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Continuation monads.+--+-----------------------------------------------------------------------------++module Control.Monad.Trans.Cont (+    -- * The Cont monad+    Cont,+    cont,+    runCont,+    mapCont,+    withCont,+    -- * The ContT monad transformer+    ContT(..),+    mapContT,+    withContT,+    callCC,+    -- * Lifting other operations+    liftLocal,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad++{- |+Continuation monad.+@Cont r a@ is a CPS computation that produces an intermediate result+of type @a@ within a CPS computation whose final result type is @r@.++The @return@ function simply creates a continuation which passes the value on.++The @>>=@ operator adds the bound function into the continuation chain.+-}+type Cont r = ContT r Identity++-- | Construct a continuation-passing computation from a function.+-- (The inverse of 'runCont'.)+cont :: ((a -> r) -> r) -> Cont r a+cont f = ContT (\ k -> Identity (f (runIdentity . k)))++-- | Runs a CPS computation, returns its result after applying the final+-- continuation to it.+-- (The inverse of 'cont'.)+runCont :: Cont r a	-- ^ continuation computation (@Cont@).+    -> (a -> r)		-- ^ the final continuation, which produces+			-- the final result (often 'id').+    -> r+runCont m k = runIdentity (runContT m (Identity . k))++-- | Apply a function to transform the result of a continuation-passing+-- computation.+--+-- * @'runCont' ('mapCont' f m) = f . 'runCont' m@+mapCont :: (r -> r) -> Cont r a -> Cont r a+mapCont f = mapContT (Identity . f . runIdentity)++-- | Apply a function to transform the continuation passed to a CPS+-- computation.+--+-- * @'runCont' ('withCont' f m) = 'runCont' m . f@+withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b+withCont f = withContT ((Identity .) . f . (runIdentity .))++{- |+The continuation monad transformer.+Can be used to add continuation handling to other monads.+-}+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }++-- | Apply a function to transform the result of a continuation-passing+-- computation.+--+-- * @'runContT' ('mapContT' f m) = f . 'runContT' m@+mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a+mapContT f m = ContT $ f . runContT m++-- | Apply a function to transform the continuation passed to a CPS+-- computation.+--+-- * @'runContT' ('withContT' f m) = 'runContT' m . f@+withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b+withContT f m = ContT $ runContT m . f++instance Functor (ContT r m) where+    fmap f m = ContT $ \c -> runContT m (c . f)++instance Applicative (ContT r m) where+    pure a  = ContT ($ a)+    f <*> v = ContT $ \ k -> runContT f $ \ g -> runContT v (k . g)++instance Monad (ContT r m) where+    return a = ContT ($ a)+    m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)++instance MonadTrans (ContT r) where+    lift m = ContT (m >>=)++instance (MonadIO m) => MonadIO (ContT r m) where+    liftIO = lift . liftIO++-- | @callCC@ (call-with-current-continuation) calls its argument+-- function, passing it the current continuation.  It provides+-- an escape continuation mechanism for use with continuation+-- monads.  Escape continuations one allow to abort the current+-- computation and return a value immediately.  They achieve a+-- similar effect to 'Control.Monad.Trans.Error.throwError'+-- and 'Control.Monad.Trans.Error.catchError' within an+-- 'Control.Monad.Trans.Error.ErrorT' monad.  The advantage of this+-- function over calling 'return' is that it makes the continuation+-- explicit, allowing more flexibility and better control.+--+-- The standard idiom used with @callCC@ is to provide a lambda-expression+-- to name the continuation. Then calling the named continuation anywhere+-- within its scope will escape from the computation, even if it is many+-- layers deep within nested computations.+callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a+callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c++-- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@.+liftLocal :: Monad m => m r' -> ((r' -> r') -> m r -> m r) ->+    (r' -> r') -> ContT r m a -> ContT r m a+liftLocal ask local f m = ContT $ \c -> do+    r <- ask+    local f (runContT m (local (const r) . c))
+ Control/Monad/Trans/Error.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Error+-- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,+--                (c) Jeff Newbern 2003-2006,+--                (c) Andriy Palamarchuk 2006+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- This monad transformer adds the ability to fail or throw exceptions+-- to a monad.+--+-- A sequence of actions succeeds, producing a value, only if all the+-- actions in the sequence are successful.  If one fails with an error,+-- the rest of the sequence is skipped and the composite action fails+-- with that error.+--+-- If the value of the error is not required, the variant in+-- "Control.Monad.Trans.Maybe" may be used instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Error (+    -- * The ErrorT monad transformer+    Error(..),+    ErrorList(..),+    ErrorT(..),+    mapErrorT,+    -- * Error operations+    throwError,+    catchError,+    -- * Lifting other operations+    liftCallCC,+    liftListen,+    liftPass,+    -- * Examples+    -- $examples+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class++import Control.Applicative+import Control.Exception (IOException)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Instances ()+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (mempty)+import Data.Traversable (Traversable(traverse))+import System.IO.Error++instance MonadPlus IO where+    mzero       = ioError (userError "mzero")+    m `mplus` n = m `catchIOError` \_ -> n++#if !(MIN_VERSION_base(4,4,0))+-- exported by System.IO.Error from base-4.4+catchIOError :: IO a -> (IOError -> IO a) -> IO a+catchIOError = catch+#endif++-- | An exception to be thrown.+--+-- Minimal complete definition: 'noMsg' or 'strMsg'.+class Error a where+    -- | Creates an exception without a message.+    -- The default implementation is @'strMsg' \"\"@.+    noMsg  :: a+    -- | Creates an exception with a message.+    -- The default implementation of @'strMsg' s@ is 'noMsg'.+    strMsg :: String -> a++    noMsg    = strMsg ""+    strMsg _ = noMsg++instance Error IOException where+    strMsg = userError++-- | A string can be thrown as an error.+instance ErrorList a => Error [a] where+    strMsg = listMsg++-- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@.+class ErrorList a where+    listMsg :: String -> [a]++instance ErrorList Char where+    listMsg = id++-- ---------------------------------------------------------------------------+-- Our parameterizable error monad++#if !(MIN_VERSION_base(4,3,0))++-- These instances are in base-4.3++instance Applicative (Either e) where+    pure          = Right+    Left  e <*> _ = Left e+    Right f <*> r = fmap f r++instance Monad (Either e) where+    return        = Right+    Left  l >>= _ = Left l+    Right r >>= k = k r++instance MonadFix (Either e) where+    mfix f = let+        a = f $ case a of+            Right r -> r+            _       -> error "empty mfix argument"+        in a++#endif /* base to 4.2.0.x */++instance (Error e) => Alternative (Either e) where+    empty        = Left noMsg+    Left _ <|> n = n+    m      <|> _ = m++instance (Error e) => MonadPlus (Either e) where+    mzero            = Left noMsg+    Left _ `mplus` n = n+    m      `mplus` _ = m++-- | The error monad transformer. It can be used to add error handling+-- to other monads.+--+-- The @ErrorT@ Monad structure is parameterized over two things:+--+-- * e - The error type.+--+-- * m - The inner monad.+--+-- The 'return' function yields a successful computation, while @>>=@+-- sequences two subcomputations, failing on the first error.+newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++-- | Map the unwrapped computation using the given function.+--+-- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@+mapErrorT :: (m (Either e a) -> n (Either e' b))+          -> ErrorT e m a+          -> ErrorT e' n b+mapErrorT f m = ErrorT $ f (runErrorT m)++instance (Functor m) => Functor (ErrorT e m) where+    fmap f = ErrorT . fmap (fmap f) . runErrorT++instance (Foldable f) => Foldable (ErrorT e f) where+    foldMap f (ErrorT a) = foldMap (either (const mempty) f) a++instance (Traversable f) => Traversable (ErrorT e f) where+    traverse f (ErrorT a) =+        ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a++instance (Functor m, Monad m) => Applicative (ErrorT e m) where+    pure a  = ErrorT $ return (Right a)+    f <*> v = ErrorT $ do+        mf <- runErrorT f+        case mf of+            Left  e -> return (Left e)+            Right k -> do+                mv <- runErrorT v+                case mv of+                    Left  e -> return (Left e)+                    Right x -> return (Right (k x))++instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m, Error e) => Monad (ErrorT e m) where+    return a = ErrorT $ return (Right a)+    m >>= k  = ErrorT $ do+        a <- runErrorT m+        case a of+            Left  l -> return (Left l)+            Right r -> runErrorT (k r)+    fail msg = ErrorT $ return (Left (strMsg msg))++instance (Monad m, Error e) => MonadPlus (ErrorT e m) where+    mzero       = ErrorT $ return (Left noMsg)+    m `mplus` n = ErrorT $ do+        a <- runErrorT m+        case a of+            Left  _ -> runErrorT n+            Right r -> return (Right r)++instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where+    mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of+        Right r -> r+        _       -> error "empty mfix argument"++instance (Error e) => MonadTrans (ErrorT e) where+    lift m = ErrorT $ do+        a <- m+        return (Right a)++instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where+    liftIO = lift . liftIO++-- | Signal an error value @e@.+--+-- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@+--+-- * @'throwError' e >>= m = 'throwError' e@+throwError :: (Monad m, Error e) => e -> ErrorT e m a+throwError l = ErrorT $ return (Left l)++-- | Handle an error.+--+-- * @'catchError' h ('lift' m) = 'lift' m@+--+-- * @'catchError' h ('throwError' e) = h e@+catchError :: (Monad m, Error e) =>+    ErrorT e m a                -- ^ the inner computation+    -> (e -> ErrorT e m a)      -- ^ a handler for errors in the inner+                                -- computation+    -> ErrorT e m a+m `catchError` h = ErrorT $ do+    a <- runErrorT m+    case a of+        Left  l -> runErrorT (h l)+        Right r -> return (Right r)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: (((Either e a -> m (Either e b)) -> m (Either e a)) ->+    m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a+liftCallCC callCC f = ErrorT $+    callCC $ \c ->+    runErrorT (f (\a -> ErrorT $ c (Right a)))++-- | Lift a @listen@ operation to the new monad.+liftListen :: Monad m =>+    (m (Either e a) -> m (Either e a,w)) -> ErrorT e m a -> ErrorT e m (a,w)+liftListen listen = mapErrorT $ \ m -> do+    (a, w) <- listen m+    return $! fmap (\ r -> (r, w)) a++-- | Lift a @pass@ operation to the new monad.+liftPass :: Monad m => (m (Either e a,w -> w) -> m (Either e a)) ->+    ErrorT e m (a,w -> w) -> ErrorT e m a+liftPass pass = mapErrorT $ \ m -> pass $ do+    a <- m+    return $! case a of+        Left  l      -> (Left  l, id)+        Right (r, f) -> (Right r, f)++{- $examples++Wrapping an IO action that can throw an error @e@:++> type ErrorWithIO e a = ErrorT e IO a+> ==> ErrorT (IO (Either e a))++An IO monad wrapped in @StateT@ inside of @ErrorT@:++> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a+> ==> ErrorT (StateT s IO (Either e a))+> ==> ErrorT (StateT (s -> IO (Either e a,s)))++-}
+ Control/Monad/Trans/Identity.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Identity+-- Copyright   :  (c) 2007 Magnus Therning+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The identity monad transformer.+--+-- This is useful for functions parameterized by a monad transformer.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Identity (+    -- * The identity monad transformer+    IdentityT(..),+    mapIdentityT,+    -- * Lifting other operations+    liftCatch,+    liftCallCC,+  ) where++import Control.Applicative+import Control.Monad (MonadPlus(mzero, mplus))+import Control.Monad.Fix (MonadFix(mfix))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Trans.Class (MonadTrans(lift))+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++-- | The trivial monad transformer, which maps a monad to an equivalent monad.+newtype IdentityT m a = IdentityT { runIdentityT :: m a }++instance (Functor m) => Functor (IdentityT m) where+    fmap f = mapIdentityT (fmap f)++instance (Foldable f) => Foldable (IdentityT f) where+    foldMap f (IdentityT a) = foldMap f a++instance (Traversable f) => Traversable (IdentityT f) where+    traverse f (IdentityT a) = IdentityT <$> traverse f a++instance (Applicative m) => Applicative (IdentityT m) where+    pure x = IdentityT (pure x)+    (<*>) = lift2IdentityT (<*>)++instance (Alternative m) => Alternative (IdentityT m) where+    empty = IdentityT empty+    (<|>) = lift2IdentityT (<|>)++instance (Monad m) => Monad (IdentityT m) where+    return = IdentityT . return+    m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m+    fail msg = IdentityT $ fail msg++instance (MonadPlus m) => MonadPlus (IdentityT m) where+    mzero = IdentityT mzero+    mplus = lift2IdentityT mplus++instance (MonadFix m) => MonadFix (IdentityT m) where+    mfix f = IdentityT (mfix (runIdentityT . f))++instance (MonadIO m) => MonadIO (IdentityT m) where+    liftIO = IdentityT . liftIO++instance MonadTrans IdentityT where+    lift = IdentityT++-- | Lift a unary operation to the new monad.+mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b+mapIdentityT f = IdentityT . f . runIdentityT++-- | Lift a binary operation to the new monad.+lift2IdentityT ::+    (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c+lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b))++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: (((a -> m b) -> m a) ->+    m a) -> ((a -> IdentityT m b) -> IdentityT m a) -> IdentityT m a+liftCallCC callCC f =+    IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c))++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m a -> (e -> m a) -> m a) ->+    IdentityT m a -> (e -> IdentityT m a) -> IdentityT m a+liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h)
+ Control/Monad/Trans/List.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.List+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The ListT monad transformer, adding backtracking to a given monad,+-- which must be commutative.+-----------------------------------------------------------------------------++module Control.Monad.Trans.List (+    -- * The ListT monad transformer+    ListT(..),+    mapListT,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class++import Control.Applicative+import Control.Monad+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++-- | Parameterizable list monad, with an inner monad.+--+-- /Note:/ this does not yield a monad unless the argument monad is commutative.+newtype ListT m a = ListT { runListT :: m [a] }++-- | Map between 'ListT' computations.+--+-- * @'runListT' ('mapListT' f m) = f ('runListT' m)@+mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b+mapListT f m = ListT $ f (runListT m)++instance (Functor m) => Functor (ListT m) where+    fmap f = mapListT $ fmap $ map f++instance Foldable f => Foldable (ListT f) where+    foldMap f (ListT a) = foldMap (foldMap f) a++instance Traversable f => Traversable (ListT f) where+    traverse f (ListT a) = ListT <$> traverse (traverse f) a++instance (Applicative m) => Applicative (ListT m) where+    pure a  = ListT $ pure [a]+    f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v++instance (Applicative m) => Alternative (ListT m) where+    empty   = ListT $ pure []+    m <|> n = ListT $ (++) <$> runListT m <*> runListT n++instance (Monad m) => Monad (ListT m) where+    return a = ListT $ return [a]+    m >>= k  = ListT $ do+        a <- runListT m+        b <- mapM (runListT . k) a+        return (concat b)+    fail _ = ListT $ return []++instance (Monad m) => MonadPlus (ListT m) where+    mzero       = ListT $ return []+    m `mplus` n = ListT $ do+        a <- runListT m+        b <- runListT n+        return (a ++ b)++instance MonadTrans ListT where+    lift m = ListT $ do+        a <- m+        return [a]++instance (MonadIO m) => MonadIO (ListT m) where+    liftIO = lift . liftIO++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: ((([a] -> m [b]) -> m [a]) -> m [a]) ->+    ((a -> ListT m b) -> ListT m a) -> ListT m a+liftCallCC callCC f = ListT $+    callCC $ \c ->+    runListT (f (\a -> ListT $ c [a]))++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m [a] -> (e -> m [a]) -> m [a]) ->+    ListT m a -> (e -> ListT m a) -> ListT m a+liftCatch catchError m h = ListT $ runListT m+    `catchError` \e -> runListT (h e)
+ Control/Monad/Trans/Maybe.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Maybe+-- Copyright   :  (c) 2007 Yitzak Gale, Eric Kidd+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The 'MaybeT' monad transformer adds the ability to fail to a monad.+--+-- A sequence of actions succeeds, producing a value, only if all the+-- actions in the sequence are successful.  If one fails, the rest of+-- the sequence is skipped and the composite action fails.+--+-- For a variant allowing a range of error values, see+-- "Control.Monad.Trans.Error".+-----------------------------------------------------------------------------++module Control.Monad.Trans.Maybe (+    -- * The MaybeT monad transformer+    MaybeT(..),+    mapMaybeT,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+    liftListen,+    liftPass,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class++import Control.Applicative+import Control.Monad (MonadPlus(mzero, mplus), liftM, ap)+import Control.Monad.Fix (MonadFix(mfix))+import Data.Foldable (Foldable(foldMap))+import Data.Maybe (fromMaybe)+import Data.Traversable (Traversable(traverse))++-- | The parameterizable maybe monad, obtained by composing an arbitrary+-- monad with the 'Maybe' monad.+--+-- Computations are actions that may produce a value or fail.+--+-- The 'return' function yields a successful computation, while @>>=@+-- sequences two subcomputations, failing on the first error.+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++-- | Transform the computation inside a @MaybeT@.+--+-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@+mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b+mapMaybeT f = MaybeT . f . runMaybeT++instance (Functor m) => Functor (MaybeT m) where+    fmap f = mapMaybeT (fmap (fmap f))++instance (Foldable f) => Foldable (MaybeT f) where+    foldMap f (MaybeT a) = foldMap (foldMap f) a++instance (Traversable f) => Traversable (MaybeT f) where+    traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a++instance (Functor m, Monad m) => Applicative (MaybeT m) where+    pure = return+    (<*>) = ap+ +instance (Functor m, Monad m) => Alternative (MaybeT m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m) => Monad (MaybeT m) where+    fail _ = MaybeT (return Nothing)+    return = lift . return+    x >>= f = MaybeT $ do+        v <- runMaybeT x+        case v of+            Nothing -> return Nothing+            Just y  -> runMaybeT (f y)++instance (Monad m) => MonadPlus (MaybeT m) where+    mzero = MaybeT (return Nothing)+    mplus x y = MaybeT $ do+        v <- runMaybeT x+        case v of+            Nothing -> runMaybeT y+            Just _  -> return v++instance (MonadFix m) => MonadFix (MaybeT m) where+    mfix f = MaybeT (mfix (runMaybeT . f . unJust))+      where unJust = fromMaybe (error "mfix MaybeT: Nothing")++instance MonadTrans MaybeT where+    lift = MaybeT . liftM Just++instance (MonadIO m) => MonadIO (MaybeT m) where+    liftIO = lift . liftIO++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: (((Maybe a -> m (Maybe b)) -> m (Maybe a)) ->+    m (Maybe a)) -> ((a -> MaybeT m b) -> MaybeT m a) -> MaybeT m a+liftCallCC callCC f =+    MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just))++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) ->+    MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a+liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h)++-- | Lift a @listen@ operation to the new monad.+liftListen :: Monad m =>+    (m (Maybe a) -> m (Maybe a,w)) -> MaybeT m a -> MaybeT m (a,w)+liftListen listen = mapMaybeT $ \ m -> do+    (a, w) <- listen m+    return $! fmap (\ r -> (r, w)) a++-- | Lift a @pass@ operation to the new monad.+liftPass :: Monad m => (m (Maybe a,w -> w) -> m (Maybe a)) ->+    MaybeT m (a,w -> w) -> MaybeT m a+liftPass pass = mapMaybeT $ \ m -> pass $ do+    a <- m+    return $! case a of+        Nothing     -> (Nothing, id)+        Just (v, f) -> (Just v, f)
+ Control/Monad/Trans/RWS.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.RWS+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.+-- This version is lazy; for a strict version, see+-- "Control.Monad.Trans.RWS.Strict", which has the same interface.+-----------------------------------------------------------------------------++module Control.Monad.Trans.RWS (+    module Control.Monad.Trans.RWS.Lazy+  ) where++import Control.Monad.Trans.RWS.Lazy
+ Control/Monad/Trans/RWS/Lazy.hs view
@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.RWS.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.+-- This version is lazy; for a strict version, see+-- "Control.Monad.Trans.RWS.Strict", which has the same interface.+-----------------------------------------------------------------------------++module Control.Monad.Trans.RWS.Lazy (+    -- * The RWS monad+    RWS,+    rws,+    runRWS,+    evalRWS,+    execRWS,+    mapRWS,+    withRWS,+    -- * The RWST monad transformer+    RWST(..),+    evalRWST,+    execRWST,+    mapRWST,+    withRWST,+    -- * Reader operations+    reader,+    ask,+    local,+    asks,+    -- * Writer operations+    writer,+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * State operations+    state,+    get,+    put,+    modify,+    gets,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Monoid++-- | A monad containing an environment of type @r@, output of type @w@+-- and an updatable state of type @s@.+type RWS r w s = RWST r w s Identity++-- | Construct an RWS computation from a function.+-- (The inverse of 'runRWS'.)+rws :: (r -> s -> (a, s, w)) -> RWS r w s a+rws f = RWST (\ r s -> Identity (f r s))++-- | Unwrap an RWS computation as a function.+-- (The inverse of 'rws'.)+runRWS :: RWS r w s a -> r -> s -> (a, s, w)+runRWS m r s = runIdentity (runRWST m r s)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (a, w)       -- ^final value and output+evalRWS m r s = let+    (a, _, w) = runRWS m r s+    in (a, w)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (s, w)       -- ^final state and output+execRWS m r s = let+    (_, s', w) = runRWS m r s+    in (s', w)++-- | Map the return value, final state and output of a computation using+-- the given function.+--+-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b+mapRWS f = mapRWST (Identity . f . runIdentity)++-- | @'withRWS' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a+withRWS = withRWST++-- ---------------------------------------------------------------------------+-- | A monad transformer adding reading an environment of type @r@,+-- collecting an output of type @w@ and updating a state of type @s@+-- to an inner monad @m@.+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (a, w)            -- ^computation yielding final value and output+evalRWST m r s = do+    ~(a, _, w) <- runRWST m r s+    return (a, w)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (s, w)            -- ^computation yielding final state and output+execRWST m r s = do+    ~(_, s', w) <- runRWST m r s+    return (s', w)++-- | Map the inner computation using the given function.+--+-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b+mapRWST f m = RWST $ \r s -> f (runRWST m r s)++-- | @'withRWST' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)++instance (Functor m) => Functor (RWST r w s m) where+    fmap f m = RWST $ \r s ->+        fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s++instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where+    pure = return+    (<*>) = ap++instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where+    empty = mzero+    (<|>) = mplus++instance (Monoid w, Monad m) => Monad (RWST r w s m) where+    return a = RWST $ \_ s -> return (a, s, mempty)+    m >>= k  = RWST $ \r s -> do+        ~(a, s', w)  <- runRWST m r s+        ~(b, s'',w') <- runRWST (k a) r s'+        return (b, s'', w `mappend` w')+    fail msg = RWST $ \_ _ -> fail msg++instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where+    mzero       = RWST $ \_ _ -> mzero+    m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s++instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where+    mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s++instance (Monoid w) => MonadTrans (RWST r w s) where+    lift m = RWST $ \_ s -> do+        a <- m+        return (a, s, mempty)++instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where+    liftIO = lift . liftIO++-- ---------------------------------------------------------------------------+-- Reader operations++-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+reader = asks++-- | Fetch the value of the environment.+ask :: (Monoid w, Monad m) => RWST r w s m r+ask = RWST $ \r s -> return (r, s, mempty)++-- | Execute a computation in a modified environment+--+-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@+local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a+local f m = RWST $ \r s -> runRWST m (f r) s++-- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@+asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+asks f = RWST $ \r s -> return (f r, s, mempty)++-- ---------------------------------------------------------------------------+-- Writer operations++-- | Construct a writer computation from a (result, output) pair.+writer :: Monad m => (a, w) -> RWST r w s m a+writer (a, w) = RWST $ \_ s -> return (a, s, w)++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> RWST r w s m ()+tell w = RWST $ \_ s -> return ((),s,w)++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runRWST' ('listen' m) r s = 'liftM' (\\(a, w) -> ((a, w), w)) ('runRWST' m r s)@+listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w)+listen m = RWST $ \r s -> do+    ~(a, s', w) <- runRWST m r s+    return ((a, w), s', w)++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runRWST' m r s)@+listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)+listens f m = RWST $ \r s -> do+    ~(a, s', w) <- runRWST m r s+    return ((a, f w), s', w)++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runRWST' ('pass' m) r s = 'liftM' (\\((a, f), w) -> (a, f w)) ('runRWST' m r s)@+pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a+pass m = RWST $ \r s -> do+    ~((a, f), s', w) <- runRWST m r s+    return (a, s', f w)++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+--+-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\(a, w) -> (a, f w)) ('runRWST' m r s)@+censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a+censor f m = RWST $ \r s -> do+    ~(a, s', w) <- runRWST m r s+    return (a, s', f w)++-- ---------------------------------------------------------------------------+-- State operations++-- | Construct a state monad computation from a state transformer function.+state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a+state f = RWST $ \_ s -> let (a,s') = f s  in  return (a, s', mempty)++-- | Fetch the current value of the state within the monad.+get :: (Monoid w, Monad m) => RWST r w s m s+get = RWST $ \_ s -> return (s, s, mempty)++-- | @'put' s@ sets the state within the monad to @s@.+put :: (Monoid w, Monad m) => s -> RWST r w s m ()+put s = RWST $ \_ _ -> return ((), s, mempty)++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@+modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()+modify f = RWST $ \_ s -> return ((), f s, mempty)+ +-- | Get a specific component of the state, using a projection function+-- supplied.+--+-- * @'gets' f = 'liftM' f 'get'@+gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a+gets f = RWST $ \_ s -> return (f s, s, mempty)++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original state on entering the+-- continuation.+liftCallCC :: (Monoid w) =>+    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->+    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a+liftCallCC callCC f = RWST $ \r s ->+    callCC $ \c ->+    runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current state on entering the continuation.+liftCallCC' :: (Monoid w) =>+    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->+    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a+liftCallCC' callCC f = RWST $ \r s ->+    callCC $ \c ->+    runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) ->+    RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a+liftCatch catchError m h =+    RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s
+ Control/Monad/Trans/RWS/Strict.hs view
@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.RWS.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'.+-- This version is strict; for a lazy version, see+-- "Control.Monad.Trans.RWS.Lazy", which has the same interface.+-----------------------------------------------------------------------------++module Control.Monad.Trans.RWS.Strict (+    -- * The RWS monad+    RWS,+    rws,+    runRWS,+    evalRWS,+    execRWS,+    mapRWS,+    withRWS,+    -- * The RWST monad transformer+    RWST(..),+    evalRWST,+    execRWST,+    mapRWST,+    withRWST,+    -- * Reader operations+    reader,+    ask,+    local,+    asks,+    -- * Writer operations+    writer,+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * State operations+    state,+    get,+    put,+    modify,+    gets,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Monoid++-- | A monad containing an environment of type @r@, output of type @w@+-- and an updatable state of type @s@.+type RWS r w s = RWST r w s Identity++-- | Construct an RWS computation from a function.+-- (The inverse of 'runRWS'.)+rws :: (r -> s -> (a, s, w)) -> RWS r w s a+rws f = RWST (\ r s -> Identity (f r s))++-- | Unwrap an RWS computation as a function.+-- (The inverse of 'rws'.)+runRWS :: RWS r w s a -> r -> s -> (a, s, w)+runRWS m r s = runIdentity (runRWST m r s)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (a, w)       -- ^final value and output+evalRWS m r s = let+    (a, _, w) = runRWS m r s+    in (a, w)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWS :: RWS r w s a  -- ^RWS computation to execute+        -> r            -- ^initial environment+        -> s            -- ^initial value+        -> (s, w)       -- ^final state and output+execRWS m r s = let+    (_, s', w) = runRWS m r s+    in (s', w)++-- | Map the return value, final state and output of a computation using+-- the given function.+--+-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b+mapRWS f = mapRWST (Identity . f . runIdentity)++-- | @'withRWS' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a+withRWS = withRWST++-- ---------------------------------------------------------------------------+-- | A monad transformer adding reading an environment of type @r@,+-- collecting an output of type @w@ and updating a state of type @s@+-- to an inner monad @m@.+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }++-- | Evaluate a computation with the given initial state and environment,+-- returning the final value and output, discarding the final state.+evalRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (a, w)            -- ^computation yielding final value and output+evalRWST m r s = do+    (a, _, w) <- runRWST m r s+    return (a, w)++-- | Evaluate a computation with the given initial state and environment,+-- returning the final state and output, discarding the final value.+execRWST :: (Monad m)+         => RWST r w s m a      -- ^computation to execute+         -> r                   -- ^initial environment+         -> s                   -- ^initial value+         -> m (s, w)            -- ^computation yielding final state and output+execRWST m r s = do+    (_, s', w) <- runRWST m r s+    return (s', w)++-- | Map the inner computation using the given function.+--+-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b+mapRWST f m = RWST $ \r s -> f (runRWST m r s)++-- | @'withRWST' f m@ executes action @m@ with an initial environment+-- and state modified by applying @f@.+--+-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)++instance (Functor m) => Functor (RWST r w s m) where+    fmap f m = RWST $ \r s ->+        fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s++instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where+    pure = return+    (<*>) = ap++instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where+    empty = mzero+    (<|>) = mplus++instance (Monoid w, Monad m) => Monad (RWST r w s m) where+    return a = RWST $ \_ s -> return (a, s, mempty)+    m >>= k  = RWST $ \r s -> do+        (a, s', w)  <- runRWST m r s+        (b, s'',w') <- runRWST (k a) r s'+        return (b, s'', w `mappend` w')+    fail msg = RWST $ \_ _ -> fail msg++instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where+    mzero       = RWST $ \_ _ -> mzero+    m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s++instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where+    mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s++instance (Monoid w) => MonadTrans (RWST r w s) where+    lift m = RWST $ \_ s -> do+        a <- m+        return (a, s, mempty)++instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where+    liftIO = lift . liftIO++-- ---------------------------------------------------------------------------+-- Reader operations++-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+reader = asks++-- | Fetch the value of the environment.+ask :: (Monoid w, Monad m) => RWST r w s m r+ask = RWST $ \r s -> return (r, s, mempty)++-- | Execute a computation in a modified environment+--+-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@+local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a+local f m = RWST $ \r s -> runRWST m (f r) s++-- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@+asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a+asks f = RWST $ \r s -> return (f r, s, mempty)++-- ---------------------------------------------------------------------------+-- Writer operations++-- | Construct a writer computation from a (result, output) pair.+writer :: Monad m => (a, w) -> RWST r w s m a+writer (a, w) = RWST $ \_ s -> return (a, s, w)++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> RWST r w s m ()+tell w = RWST $ \_ s -> return ((),s,w)++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runRWST' ('listen' m) r s = 'liftM' (\\(a, w) -> ((a, w), w)) ('runRWST' m r s)@+listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w)+listen m = RWST $ \r s -> do+    (a, s', w) <- runRWST m r s+    return ((a, w), s', w)++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runRWST' m r s)@+listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b)+listens f m = RWST $ \r s -> do+    (a, s', w) <- runRWST m r s+    return ((a, f w), s', w)++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runRWST' ('pass' m) r s = 'liftM' (\\((a, f), w) -> (a, f w)) ('runRWST' m r s)@+pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a+pass m = RWST $ \r s -> do+    ((a, f), s', w) <- runRWST m r s+    return (a, s', f w)++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+--+-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\(a, w) -> (a, f w)) ('runRWST' m r s)@+censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a+censor f m = RWST $ \r s -> do+    (a, s', w) <- runRWST m r s+    return (a, s', f w)++-- ---------------------------------------------------------------------------+-- State operations++-- | Construct a state monad computation from a state transformer function.+state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a+state f = RWST $ \_ s -> case f s of (a,s') -> return (a, s', mempty)++-- | Fetch the current value of the state within the monad.+get :: (Monoid w, Monad m) => RWST r w s m s+get = RWST $ \_ s -> return (s, s, mempty)++-- | @'put' s@ sets the state within the monad to @s@.+put :: (Monoid w, Monad m) => s -> RWST r w s m ()+put s = RWST $ \_ _ -> return ((), s, mempty)++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@+modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m ()+modify f = RWST $ \_ s -> return ((), f s, mempty)+ +-- | Get a specific component of the state, using a projection function+-- supplied.+--+-- * @'gets' f = 'liftM' f 'get'@+gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a+gets f = RWST $ \_ s -> return (f s, s, mempty)++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original state on entering the+-- continuation.+liftCallCC :: (Monoid w) =>+    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->+    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a+liftCallCC callCC f = RWST $ \r s ->+    callCC $ \c ->+    runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current state on entering the continuation.+liftCallCC' :: (Monoid w) =>+    ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ->+    ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a+liftCallCC' callCC f = RWST $ \r s ->+    callCC $ \c ->+    runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) ->+    RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a+liftCatch catchError m h =+    RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s
+ Control/Monad/Trans/Reader.hs view
@@ -0,0 +1,180 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Reader+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Declaration of the 'ReaderT' monad transformer, which adds a static+-- environment to a given monad.+--+-- If the computation is to modify the stored information, use+-- "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Reader (+    -- * The Reader monad+    Reader,+    reader,+    runReader,+    mapReader,+    withReader,+    -- * The ReaderT monad transformer+    ReaderT(..),+    mapReaderT,+    withReaderT,+    -- * Reader operations+    ask,+    local,+    asks,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+    ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Instances ()++-- | The parameterizable reader monad.+--+-- Computations are functions of a shared environment.+--+-- The 'return' function ignores the environment, while @>>=@ passes+-- the inherited environment to both subcomputations.+type Reader r = ReaderT r Identity++-- | Constructor for computations in the reader monad (equivalent to 'asks').+reader :: Monad m => (r -> a) -> ReaderT r m a+reader f = ReaderT (return . f)++-- | Runs a @Reader@ and extracts the final value from it.+-- (The inverse of 'reader'.)+runReader :: Reader r a		-- ^ A @Reader@ to run.+    -> r			-- ^ An initial environment.+    -> a+runReader m = runIdentity . runReaderT m++-- | Transform the value returned by a @Reader@.+--+-- * @'runReader' ('mapReader' f m) = f . 'runReader' m@+mapReader :: (a -> b) -> Reader r a -> Reader r b+mapReader f = mapReaderT (Identity . f . runIdentity)++-- | Execute a computation in a modified environment+-- (a specialization of 'withReaderT').+--+-- * @'runReader' ('withReader' f m) = 'runReader' m . f@+withReader+    :: (r' -> r)        -- ^ The function to modify the environment.+    -> Reader r a       -- ^ Computation to run in the modified environment.+    -> Reader r' a+withReader = withReaderT++-- | The reader monad transformer,+-- which adds a read-only environment to the given monad.+--+-- The 'return' function ignores the environment, while @>>=@ passes+-- the inherited environment to both subcomputations.+newtype ReaderT r m a = ReaderT {+        -- | The underlying computation, as a function of the environment.+        runReaderT :: r -> m a+    }++-- | Transform the computation inside a @ReaderT@.+--+-- * @'runReaderT' ('mapReaderT' f m) = f . 'runReaderT' m@+mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b+mapReaderT f m = ReaderT $ f . runReaderT m++-- | Execute a computation in a modified environment+-- (a more general version of 'local').+--+-- * @'runReaderT' ('withReaderT' f m) = 'runReaderT' m . f@+withReaderT+    :: (r' -> r)        -- ^ The function to modify the environment.+    -> ReaderT r m a    -- ^ Computation to run in the modified environment.+    -> ReaderT r' m a+withReaderT f m = ReaderT $ runReaderT m . f++instance (Functor m) => Functor (ReaderT r m) where+    fmap f  = mapReaderT (fmap f)++instance (Applicative m) => Applicative (ReaderT r m) where+    pure    = liftReaderT . pure+    f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r++instance (Alternative m) => Alternative (ReaderT r m) where+    empty   = liftReaderT empty+    m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r++instance (Monad m) => Monad (ReaderT r m) where+    return   = lift . return+    m >>= k  = ReaderT $ \ r -> do+        a <- runReaderT m r+        runReaderT (k a) r+    fail msg = lift (fail msg)++instance (MonadPlus m) => MonadPlus (ReaderT r m) where+    mzero       = lift mzero+    m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r++instance (MonadFix m) => MonadFix (ReaderT r m) where+    mfix f = ReaderT $ \ r -> mfix $ \ a -> runReaderT (f a) r++instance MonadTrans (ReaderT r) where+    lift   = liftReaderT++instance (MonadIO m) => MonadIO (ReaderT r m) where+    liftIO = lift . liftIO++liftReaderT :: m a -> ReaderT r m a+liftReaderT m = ReaderT (const m)++-- | Fetch the value of the environment.+ask :: (Monad m) => ReaderT r m r+ask = ReaderT return++-- | Execute a computation in a modified environment+-- (a specialization of 'withReaderT').+--+-- * @'runReaderT' ('local' f m) = 'runReaderT' m . f@+local :: (Monad m)+    => (r -> r)         -- ^ The function to modify the environment.+    -> ReaderT r m a    -- ^ Computation to run in the modified environment.+    -> ReaderT r m a+local = withReaderT++-- | Retrieve a function of the current environment.+--+-- * @'asks' f = 'liftM' f 'ask'@+asks :: (Monad m)+    => (r -> a)         -- ^ The selector function to apply to the environment.+    -> ReaderT r m a+asks f = ReaderT (return . f)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC ::+    (((a -> m b) -> m a) -> m a)        -- ^ @callCC@ on the argument monad.+    -> ((a -> ReaderT r m b) -> ReaderT r m a) -> ReaderT r m a+liftCallCC callCC f = ReaderT $ \ r ->+    callCC $ \ c ->+    runReaderT (f (ReaderT . const . c)) r++-- | Lift a @catchError@ operation to the new monad.+liftCatch ::+    (m a -> (e -> m a) -> m a)          -- ^ @catch@ on the argument monad.+    -> ReaderT r m a                    -- ^ Computation to attempt.+    -> (e -> ReaderT r m a)             -- ^ Exception handler.+    -> ReaderT r m a+liftCatch f m h =+    ReaderT $ \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r)
+ Control/Monad/Trans/State.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.State+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- State monads, passing an updatable state through a computation.+--+-- Some computations may not require the full power of state transformers:+--+-- * For a read-only state, see "Control.Monad.Trans.Reader".+--+-- * To accumulate a value without using it on the way, see+--   "Control.Monad.Trans.Writer".+--+-- This version is lazy; for a strict version, see+-- "Control.Monad.Trans.State.Strict", which has the same interface.+-----------------------------------------------------------------------------++module Control.Monad.Trans.State (+  module Control.Monad.Trans.State.Lazy+  ) where++import Control.Monad.Trans.State.Lazy
+ Control/Monad/Trans/State/Lazy.hs view
@@ -0,0 +1,366 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.State.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Lazy state monads, passing an updatable state through a computation.+-- See below for examples.+--+-- In this version, sequencing of computations is lazy.+-- For a strict version, see "Control.Monad.Trans.State.Strict", which+-- has the same interface.+--+-- Some computations may not require the full power of state transformers:+--+-- * For a read-only state, see "Control.Monad.Trans.Reader".+--+-- * To accumulate a value without using it on the way, see+--   "Control.Monad.Trans.Writer".+-----------------------------------------------------------------------------++module Control.Monad.Trans.State.Lazy (+    -- * The State monad+    State,+    state,+    runState,+    evalState,+    execState,+    mapState,+    withState,+    -- * The StateT monad transformer+    StateT(..),+    evalStateT,+    execStateT,+    mapStateT,+    withStateT,+    -- * State operations+    get,+    put,+    modify,+    gets,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+    liftListen,+    liftPass,+    -- * Examples+    -- ** State monads+    -- $examples++    -- ** Counting+    -- $counting++    -- ** Labelling trees+    -- $labelling+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix++-- ---------------------------------------------------------------------------+-- | A state monad parameterized by the type @s@ of the state to carry.+--+-- The 'return' function leaves the state unchanged, while @>>=@ uses+-- the final state of the first computation as the initial state of+-- the second.+type State s = StateT s Identity++-- | Construct a state monad computation from a function.+-- (The inverse of 'runState'.)+state :: Monad m+      => (s -> (a, s))  -- ^pure state transformer+      -> StateT s m a   -- ^equivalent state-passing computation+state f = StateT (return . f)++-- | Unwrap a state monad computation as a function.+-- (The inverse of 'state'.)+runState :: State s a   -- ^state-passing computation to execute+         -> s           -- ^initial state+         -> (a, s)      -- ^return value and final state+runState m = runIdentity . runStateT m++-- | Evaluate a state computation with the given initial state+-- and return the final value, discarding the final state.+--+-- * @'evalState' m s = 'fst' ('runState' m s)@+evalState :: State s a  -- ^state-passing computation to execute+          -> s          -- ^initial value+          -> a          -- ^return value of the state computation+evalState m s = fst (runState m s)++-- | Evaluate a state computation with the given initial state+-- and return the final state, discarding the final value.+--+-- * @'execState' m s = 'snd' ('runState' m s)@+execState :: State s a  -- ^state-passing computation to execute+          -> s          -- ^initial value+          -> s          -- ^final state+execState m s = snd (runState m s)++-- | Map both the return value and final state of a computation using+-- the given function.+--+-- * @'runState' ('mapState' f m) = f . 'runState' m@+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b+mapState f = mapStateT (Identity . f . runIdentity)++-- | @'withState' f m@ executes action @m@ on a state modified by+-- applying @f@.+--+-- * @'withState' f m = 'modify' f >> m@+withState :: (s -> s) -> State s a -> State s a+withState = withStateT++-- ---------------------------------------------------------------------------+-- | A state transformer monad parameterized by:+--+--   * @s@ - The state.+--+--   * @m@ - The inner monad.+--+-- The 'return' function leaves the state unchanged, while @>>=@ uses+-- the final state of the first computation as the initial state of+-- the second.+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }++-- | Evaluate a state computation with the given initial state+-- and return the final value, discarding the final state.+--+-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@+evalStateT :: (Monad m) => StateT s m a -> s -> m a+evalStateT m s = do+    ~(a, _) <- runStateT m s+    return a++-- | Evaluate a state computation with the given initial state+-- and return the final state, discarding the final value.+--+-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@+execStateT :: (Monad m) => StateT s m a -> s -> m s+execStateT m s = do+    ~(_, s') <- runStateT m s+    return s'++-- | Map both the return value and final state of a computation using+-- the given function.+--+-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b+mapStateT f m = StateT $ f . runStateT m++-- | @'withStateT' f m@ executes action @m@ on a state modified by+-- applying @f@.+--+-- * @'withStateT' f m = 'modify' f >> m@+withStateT :: (s -> s) -> StateT s m a -> StateT s m a+withStateT f m = StateT $ runStateT m . f++instance (Functor m) => Functor (StateT s m) where+    fmap f m = StateT $ \ s ->+        fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s++instance (Functor m, Monad m) => Applicative (StateT s m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (StateT s m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m) => Monad (StateT s m) where+    return a = state $ \s -> (a, s)+    m >>= k  = StateT $ \s -> do+        ~(a, s') <- runStateT m s+        runStateT (k a) s'+    fail str = StateT $ \_ -> fail str++instance (MonadPlus m) => MonadPlus (StateT s m) where+    mzero       = StateT $ \_ -> mzero+    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s++instance (MonadFix m) => MonadFix (StateT s m) where+    mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s++instance MonadTrans (StateT s) where+    lift m = StateT $ \s -> do+        a <- m+        return (a, s)++instance (MonadIO m) => MonadIO (StateT s m) where+    liftIO = lift . liftIO++-- | Fetch the current value of the state within the monad.+get :: (Monad m) => StateT s m s+get = state $ \s -> (s, s)++-- | @'put' s@ sets the state within the monad to @s@.+put :: (Monad m) => s -> StateT s m ()+put s = state $ \_ -> ((), s)++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@+modify :: (Monad m) => (s -> s) -> StateT s m ()+modify f = state $ \s -> ((), f s)++-- | Get a specific component of the state, using a projection function+-- supplied.+--+-- * @'gets' f = 'liftM' f 'get'@+gets :: (Monad m) => (s -> a) -> StateT s m a+gets f = state $ \s -> (f s, s)++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original state on entering the+-- continuation.+liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->+    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a+liftCallCC callCC f = StateT $ \s ->+    callCC $ \c ->+    runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current state on entering the continuation.+-- It does not satisfy the laws of a monad transformer.+liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->+    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a+liftCallCC' callCC f = StateT $ \s ->+    callCC $ \c ->+    runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) ->+    StateT s m a -> (e -> StateT s m a) -> StateT s m a+liftCatch catchError m h =+    StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s++-- | Lift a @listen@ operation to the new monad.+liftListen :: Monad m =>+    (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w)+liftListen listen m = StateT $ \s -> do+    ~((a, s'), w) <- listen (runStateT m s)+    return ((a, w), s')++-- | Lift a @pass@ operation to the new monad.+liftPass :: Monad m =>+    (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a+liftPass pass m = StateT $ \s -> pass $ do+    ~((a, f), s') <- runStateT m s+    return ((a, s'), f)++{- $examples++Parser from ParseLib with Hugs:++> type Parser a = StateT String [] a+>    ==> StateT (String -> [(a,String)])++For example, item can be written as:++> item = do (x:xs) <- get+>        put xs+>        return x+>+> type BoringState s a = StateT s Identity a+>      ==> StateT (s -> Identity (a,s))+>+> type StateWithIO s a = StateT s IO a+>      ==> StateT (s -> IO (a,s))+>+> type StateWithErr s a = StateT s Maybe a+>      ==> StateT (s -> Maybe (a,s))++-}++{- $counting++A function to increment a counter.+Taken from the paper \"Generalising Monads to Arrows\",+John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998:++> tick :: State Int Int+> tick = do n <- get+>           put (n+1)+>           return n++Add one to the given number using the state monad:++> plusOne :: Int -> Int+> plusOne n = execState tick n++A contrived addition example. Works only with positive numbers:++> plus :: Int -> Int -> Int+> plus n x = execState (sequence $ replicate n tick) x++-}++{- $labelling++An example from /The Craft of Functional Programming/, Simon+Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),+Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a+tree of integers in which the original elements are replaced by+natural numbers, starting from 0.  The same element has to be+replaced by the same number at every occurrence, and when we meet+an as-yet-unvisited element we have to find a \'new\' number to match+it with:\"++> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)+> type Table a = [a]++> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)+> numberTree Nil = return Nil+> numberTree (Node x t1 t2)+>        =  do num <- numberNode x+>              nt1 <- numberTree t1+>              nt2 <- numberTree t2+>              return (Node num nt1 nt2)+>     where+>     numberNode :: Eq a => a -> State (Table a) Int+>     numberNode x+>        = do table <- get+>             (newTable, newPos) <- return (nNode x table)+>             put newTable+>             return newPos+>     nNode::  (Eq a) => a -> Table a -> (Table a, Int)+>     nNode x table+>        = case (findIndexInList (== x) table) of+>          Nothing -> (table ++ [x], length table)+>          Just i  -> (table, i)+>     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int+>     findIndexInList = findIndexInListHelp 0+>     findIndexInListHelp _ _ [] = Nothing+>     findIndexInListHelp count f (h:t)+>        = if (f h)+>          then Just count+>          else findIndexInListHelp (count+1) f t++numTree applies numberTree with an initial state:++> numTree :: (Eq a) => Tree a -> Tree Int+> numTree t = evalState (numberTree t) []++> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil+> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil++sumTree is a little helper function that does not use the State monad:++> sumTree :: (Num a) => Tree a -> a+> sumTree Nil = 0+> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)++-}
+ Control/Monad/Trans/State/Strict.hs view
@@ -0,0 +1,366 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.State.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Strict state monads, passing an updatable state through a computation.+-- See below for examples.+--+-- In this version, sequencing of computations is strict.+-- For a lazy version, see "Control.Monad.Trans.State.Lazy", which+-- has the same interface.+--+-- Some computations may not require the full power of state transformers:+--+-- * For a read-only state, see "Control.Monad.Trans.Reader".+--+-- * To accumulate a value without using it on the way, see+--   "Control.Monad.Trans.Writer".+-----------------------------------------------------------------------------++module Control.Monad.Trans.State.Strict (+    -- * The State monad+    State,+    state,+    runState,+    evalState,+    execState,+    mapState,+    withState,+    -- * The StateT monad transformer+    StateT(..),+    evalStateT,+    execStateT,+    mapStateT,+    withStateT,+    -- * State operations+    get,+    put,+    modify,+    gets,+    -- * Lifting other operations+    liftCallCC,+    liftCallCC',+    liftCatch,+    liftListen,+    liftPass,+    -- * Examples+    -- ** State monads+    -- $examples++    -- ** Counting+    -- $counting++    -- ** Labelling trees+    -- $labelling+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix++-- ---------------------------------------------------------------------------+-- | A state monad parameterized by the type @s@ of the state to carry.+--+-- The 'return' function leaves the state unchanged, while @>>=@ uses+-- the final state of the first computation as the initial state of+-- the second.+type State s = StateT s Identity++-- | Construct a state monad computation from a function.+-- (The inverse of 'runState'.)+state :: Monad m+      => (s -> (a, s))  -- ^pure state transformer+      -> StateT s m a   -- ^equivalent state-passing computation+state f = StateT (return . f)++-- | Unwrap a state monad computation as a function.+-- (The inverse of 'state'.)+runState :: State s a   -- ^state-passing computation to execute+         -> s           -- ^initial state+         -> (a, s)      -- ^return value and final state+runState m = runIdentity . runStateT m++-- | Evaluate a state computation with the given initial state+-- and return the final value, discarding the final state.+--+-- * @'evalState' m s = 'fst' ('runState' m s)@+evalState :: State s a  -- ^state-passing computation to execute+          -> s          -- ^initial value+          -> a          -- ^return value of the state computation+evalState m s = fst (runState m s)++-- | Evaluate a state computation with the given initial state+-- and return the final state, discarding the final value.+--+-- * @'execState' m s = 'snd' ('runState' m s)@+execState :: State s a  -- ^state-passing computation to execute+          -> s          -- ^initial value+          -> s          -- ^final state+execState m s = snd (runState m s)++-- | Map both the return value and final state of a computation using+-- the given function.+--+-- * @'runState' ('mapState' f m) = f . 'runState' m@+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b+mapState f = mapStateT (Identity . f . runIdentity)++-- | @'withState' f m@ executes action @m@ on a state modified by+-- applying @f@.+--+-- * @'withState' f m = 'modify' f >> m@+withState :: (s -> s) -> State s a -> State s a+withState = withStateT++-- ---------------------------------------------------------------------------+-- | A state transformer monad parameterized by:+--+--   * @s@ - The state.+--+--   * @m@ - The inner monad.+--+-- The 'return' function leaves the state unchanged, while @>>=@ uses+-- the final state of the first computation as the initial state of+-- the second.+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }++-- | Evaluate a state computation with the given initial state+-- and return the final value, discarding the final state.+--+-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@+evalStateT :: (Monad m) => StateT s m a -> s -> m a+evalStateT m s = do+    (a, _) <- runStateT m s+    return a++-- | Evaluate a state computation with the given initial state+-- and return the final state, discarding the final value.+--+-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@+execStateT :: (Monad m) => StateT s m a -> s -> m s+execStateT m s = do+    (_, s') <- runStateT m s+    return s'++-- | Map both the return value and final state of a computation using+-- the given function.+--+-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b+mapStateT f m = StateT $ f . runStateT m++-- | @'withStateT' f m@ executes action @m@ on a state modified by+-- applying @f@.+--+-- * @'withStateT' f m = 'modify' f >> m@+withStateT :: (s -> s) -> StateT s m a -> StateT s m a+withStateT f m = StateT $ runStateT m . f++instance (Functor m) => Functor (StateT s m) where+    fmap f m = StateT $ \ s ->+        fmap (\ (a, s') -> (f a, s')) $ runStateT m s++instance (Functor m, Monad m) => Applicative (StateT s m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (StateT s m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m) => Monad (StateT s m) where+    return a = state $ \s -> (a, s)+    m >>= k  = StateT $ \s -> do+        (a, s') <- runStateT m s+        runStateT (k a) s'+    fail str = StateT $ \_ -> fail str++instance (MonadPlus m) => MonadPlus (StateT s m) where+    mzero       = StateT $ \_ -> mzero+    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s++instance (MonadFix m) => MonadFix (StateT s m) where+    mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s++instance MonadTrans (StateT s) where+    lift m = StateT $ \s -> do+        a <- m+        return (a, s)++instance (MonadIO m) => MonadIO (StateT s m) where+    liftIO = lift . liftIO++-- | Fetch the current value of the state within the monad.+get :: (Monad m) => StateT s m s+get = state $ \s -> (s, s)++-- | @'put' s@ sets the state within the monad to @s@.+put :: (Monad m) => s -> StateT s m ()+put s = state $ \_ -> ((), s)++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+--+-- * @'modify' f = 'get' >>= ('put' . f)@+modify :: (Monad m) => (s -> s) -> StateT s m ()+modify f = state $ \s -> ((), f s)++-- | Get a specific component of the state, using a projection function+-- supplied.+--+-- * @'gets' f = 'liftM' f 'get'@+gets :: (Monad m) => (s -> a) -> StateT s m a+gets f = state $ \s -> (f s, s)++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original state on entering the+-- continuation.+liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->+    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a+liftCallCC callCC f = StateT $ \s ->+    callCC $ \c ->+    runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current state on entering the continuation.+-- It does not satisfy the laws of a monad transformer.+liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->+    ((a -> StateT s m b) -> StateT s m a) -> StateT s m a+liftCallCC' callCC f = StateT $ \s ->+    callCC $ \c ->+    runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) ->+    StateT s m a -> (e -> StateT s m a) -> StateT s m a+liftCatch catchError m h =+    StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s++-- | Lift a @listen@ operation to the new monad.+liftListen :: Monad m =>+    (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w)+liftListen listen m = StateT $ \s -> do+    ((a, s'), w) <- listen (runStateT m s)+    return ((a, w), s')++-- | Lift a @pass@ operation to the new monad.+liftPass :: Monad m =>+    (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a+liftPass pass m = StateT $ \s -> pass $ do+    ((a, f), s') <- runStateT m s+    return ((a, s'), f)++{- $examples++Parser from ParseLib with Hugs:++> type Parser a = StateT String [] a+>    ==> StateT (String -> [(a,String)])++For example, item can be written as:++> item = do (x:xs) <- get+>        put xs+>        return x+>+> type BoringState s a = StateT s Identity a+>      ==> StateT (s -> Identity (a,s))+>+> type StateWithIO s a = StateT s IO a+>      ==> StateT (s -> IO (a,s))+>+> type StateWithErr s a = StateT s Maybe a+>      ==> StateT (s -> Maybe (a,s))++-}++{- $counting++A function to increment a counter.+Taken from the paper \"Generalising Monads to Arrows\",+John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998:++> tick :: State Int Int+> tick = do n <- get+>           put (n+1)+>           return n++Add one to the given number using the state monad:++> plusOne :: Int -> Int+> plusOne n = execState tick n++A contrived addition example. Works only with positive numbers:++> plus :: Int -> Int -> Int+> plus n x = execState (sequence $ replicate n tick) x++-}++{- $labelling++An example from /The Craft of Functional Programming/, Simon+Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),+Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a+tree of integers in which the original elements are replaced by+natural numbers, starting from 0.  The same element has to be+replaced by the same number at every occurrence, and when we meet+an as-yet-unvisited element we have to find a \'new\' number to match+it with:\"++> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)+> type Table a = [a]++> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)+> numberTree Nil = return Nil+> numberTree (Node x t1 t2)+>        =  do num <- numberNode x+>              nt1 <- numberTree t1+>              nt2 <- numberTree t2+>              return (Node num nt1 nt2)+>     where+>     numberNode :: Eq a => a -> State (Table a) Int+>     numberNode x+>        = do table <- get+>             (newTable, newPos) <- return (nNode x table)+>             put newTable+>             return newPos+>     nNode::  (Eq a) => a -> Table a -> (Table a, Int)+>     nNode x table+>        = case (findIndexInList (== x) table) of+>          Nothing -> (table ++ [x], length table)+>          Just i  -> (table, i)+>     findIndexInList :: (a -> Bool) -> [a] -> Maybe Int+>     findIndexInList = findIndexInListHelp 0+>     findIndexInListHelp _ _ [] = Nothing+>     findIndexInListHelp count f (h:t)+>        = if (f h)+>          then Just count+>          else findIndexInListHelp (count+1) f t++numTree applies numberTree with an initial state:++> numTree :: (Eq a) => Tree a -> Tree Int+> numTree t = evalState (numberTree t) []++> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil+> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil++sumTree is a little helper function that does not use the State monad:++> sumTree :: (Num a) => Tree a -> a+> sumTree Nil = 0+> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)++-}
+ Control/Monad/Trans/Writer.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Writer+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The WriterT monad transformer.+-- This version is lazy; for a strict version, see+-- "Control.Monad.Trans.Writer.Strict", which has the same interface.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Writer (+    module Control.Monad.Trans.Writer.Lazy+  ) where++import Control.Monad.Trans.Writer.Lazy
+ Control/Monad/Trans/Writer/Lazy.hs view
@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Writer.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The lazy 'WriterT' monad transformer, which adds collection of+-- outputs (such as a count or string output) to a given monad.+--+-- This version builds its output lazily; for a strict version, see+-- "Control.Monad.Trans.Writer.Strict", which has the same interface.+--+-- This monad transformer provides only limited access to the output+-- during the computation.  For more general access, use+-- "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Writer.Lazy (+    -- * The Writer monad+    Writer,+    writer,+    runWriter,+    execWriter,+    mapWriter,+    -- * The WriterT monad transformer+    WriterT(..),+    execWriterT,+    mapWriterT,+    -- * Writer operations+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Foldable (Foldable(foldMap))+import Data.Monoid+import Data.Traversable (Traversable(traverse))++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by the type @w@ of output to accumulate.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+type Writer w = WriterT w Identity++-- | Construct a writer computation from a (result, output) pair.+-- (The inverse of 'runWriter'.)+writer :: Monad m => (a, w) -> WriterT w m a+writer = WriterT . return++-- | Unwrap a writer computation as a (result, output) pair.+-- (The inverse of 'writer'.)+runWriter :: Writer w a -> (a, w)+runWriter = runIdentity . runWriterT++-- | Extract the output from a writer computation.+--+-- * @'execWriter' m = 'snd' ('runWriter' m)@+execWriter :: Writer w a -> w+execWriter m = snd (runWriter m)++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b+mapWriter f = mapWriterT (Identity . f . runIdentity)++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by:+--+--   * @w@ - the output to accumulate.+--+--   * @m@ - The inner monad.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }++-- | Extract the output from a writer computation.+--+-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@+execWriterT :: Monad m => WriterT w m a -> m w+execWriterT m = do+    ~(_, w) <- runWriterT m+    return w++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b+mapWriterT f m = WriterT $ f (runWriterT m)++instance (Functor m) => Functor (WriterT w m) where+    fmap f = mapWriterT $ fmap $ \ ~(a, w) -> (f a, w)++instance (Monoid w, Applicative m) => Applicative (WriterT w m) where+    pure a  = WriterT $ pure (a, mempty)+    f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)+      where k ~(a, w) ~(b, w') = (a b, w `mappend` w')++instance (Monoid w, Alternative m) => Alternative (WriterT w m) where+    empty   = WriterT empty+    m <|> n = WriterT $ runWriterT m <|> runWriterT n++instance (Monoid w, Monad m) => Monad (WriterT w m) where+    return a = writer (a, mempty)+    m >>= k  = WriterT $ do+        ~(a, w)  <- runWriterT m+        ~(b, w') <- runWriterT (k a)+        return (b, w `mappend` w')+    fail msg = WriterT $ fail msg++instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where+    mzero       = WriterT mzero+    m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n++instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where+    mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)++instance (Monoid w) => MonadTrans (WriterT w) where+    lift m = WriterT $ do+        a <- m+        return (a, mempty)++instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where+    liftIO = lift . liftIO++instance Foldable f => Foldable (WriterT w f) where+    foldMap f (WriterT a) = foldMap (f . fst) a++instance Traversable f => Traversable (WriterT w f) where+    traverse f (WriterT a) = WriterT <$> traverse f' a where+       f' (a, b) = fmap (\c -> (c, b)) (f a)++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> WriterT w m ()+tell w = writer ((), w)++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@+listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)+listen m = WriterT $ do+    ~(a, w) <- runWriterT m+    return ((a, w), w)++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@+listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)+listens f m = WriterT $ do+    ~(a, w) <- runWriterT m+    return ((a, f w), w)++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@+pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a+pass m = WriterT $ do+    ~((a, f), w) <- runWriterT m+    return (a, f w)++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+--+-- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@+censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a+censor f m = WriterT $ do+    ~(a, w) <- runWriterT m+    return (a, f w)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) ->+    ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a+liftCallCC callCC f = WriterT $+    callCC $ \c ->+    runWriterT (f (\a -> WriterT $ c (a, mempty)))++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) ->+    WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a+liftCatch catchError m h =+    WriterT $ runWriterT m `catchError` \e -> runWriterT (h e)
+ Control/Monad/Trans/Writer/Strict.hs view
@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Writer.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The strict 'WriterT' monad transformer, which adds collection of+-- outputs (such as a count or string output) to a given monad.+--+-- This version builds its output strictly; for a lazy version, see+-- "Control.Monad.Trans.Writer.Lazy", which has the same interface.+--+-- This monad transformer provides only limited access to the output+-- during the computation.  For more general access, use+-- "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Writer.Strict (+    -- * The Writer monad+    Writer,+    writer,+    runWriter,+    execWriter,+    mapWriter,+    -- * The WriterT monad transformer+    WriterT(..),+    execWriterT,+    mapWriterT,+    -- * Writer operations+    tell,+    listen,+    listens,+    pass,+    censor,+    -- * Lifting other operations+    liftCallCC,+    liftCatch,+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Foldable (Foldable(foldMap))+import Data.Monoid+import Data.Traversable (Traversable(traverse))++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by the type @w@ of output to accumulate.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+type Writer w = WriterT w Identity++-- | Construct a writer computation from a (result, output) pair.+-- (The inverse of 'runWriter'.)+writer :: Monad m => (a, w) -> WriterT w m a+writer = WriterT . return++-- | Unwrap a writer computation as a (result, output) pair.+-- (The inverse of 'writer'.)+runWriter :: Writer w a -> (a, w)+runWriter = runIdentity . runWriterT++-- | Extract the output from a writer computation.+--+-- * @'execWriter' m = 'snd' ('runWriter' m)@+execWriter :: Writer w a -> w+execWriter m = snd (runWriter m)++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b+mapWriter f = mapWriterT (Identity . f . runIdentity)++-- ---------------------------------------------------------------------------+-- | A writer monad parameterized by:+--+--   * @w@ - the output to accumulate.+--+--   * @m@ - The inner monad.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }++-- | Extract the output from a writer computation.+--+-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@+execWriterT :: Monad m => WriterT w m a -> m w+execWriterT m = do+    (_, w) <- runWriterT m+    return w++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b+mapWriterT f m = WriterT $ f (runWriterT m)++instance (Functor m) => Functor (WriterT w m) where+    fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w)++instance (Foldable f) => Foldable (WriterT w f) where+    foldMap f (WriterT a) = foldMap (f . fst) a++instance (Traversable f) => Traversable (WriterT w f) where+    traverse f (WriterT a) = WriterT <$> traverse f' a where+       f' (a, b) = fmap (\c -> (c, b)) (f a)++instance (Monoid w, Applicative m) => Applicative (WriterT w m) where+    pure a  = WriterT $ pure (a, mempty)+    f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)+      where k (a, w) (b, w') = (a b, w `mappend` w')++instance (Monoid w, Alternative m) => Alternative (WriterT w m) where+    empty   = WriterT empty+    m <|> n = WriterT $ runWriterT m <|> runWriterT n++instance (Monoid w, Monad m) => Monad (WriterT w m) where+    return a = WriterT $ return (a, mempty)+    m >>= k  = WriterT $ do+        (a, w)  <- runWriterT m+        (b, w') <- runWriterT (k a)+        return (b, w `mappend` w')+    fail msg = WriterT $ fail msg++instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where+    mzero       = WriterT mzero+    m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n++instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where+    mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)++instance (Monoid w) => MonadTrans (WriterT w) where+    lift m = WriterT $ do+        a <- m+        return (a, mempty)++instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where+    liftIO = lift . liftIO++-- | @'tell' w@ is an action that produces the output @w@.+tell :: (Monoid w, Monad m) => w -> WriterT w m ()+tell w = WriterT $ return ((), w)++-- | @'listen' m@ is an action that executes the action @m@ and adds its+-- output to the value of the computation.+--+-- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@+listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w)+listen m = WriterT $ do+    (a, w) <- runWriterT m+    return ((a, w), w)++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+--+-- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@+listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b)+listens f m = WriterT $ do+    (a, w) <- runWriterT m+    return ((a, f w), w)++-- | @'pass' m@ is an action that executes the action @m@, which returns+-- a value and a function, and returns the value, applying the function+-- to the output.+--+-- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@+pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a+pass m = WriterT $ do+    ((a, f), w) <- runWriterT m+    return (a, f w)++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+--+-- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@+censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a+censor f m = WriterT $ do+    (a, w) <- runWriterT m+    return (a, f w)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) ->+    ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a+liftCallCC callCC f = WriterT $+    callCC $ \c ->+    runWriterT (f (\a -> WriterT $ c (a, mempty)))++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) ->+    WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a+liftCatch catchError m h =+    WriterT $ runWriterT m `catchError` \e -> runWriterT (h e)
+ Control/Monad/Writer.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Writer+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- The MonadWriter class.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.Writer (+    module Control.Monad.Writer.Lazy+  ) where++import Control.Monad.Writer.Lazy
+ Control/Monad/Writer/Class.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE UndecidableInstances #-}+-- Search for UndecidableInstances to see why this is needed++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Writer.Class+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- The MonadWriter class.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.Writer.Class (+    MonadWriter(..),+    listens,+    censor,+  ) where++import Control.Monad.Trans.Error as Error+import Control.Monad.Trans.Identity as Identity+import Control.Monad.Trans.Maybe as Maybe+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (+        RWST, writer, tell, listen, pass)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (+        RWST, writer, tell, listen, pass)+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (+        WriterT, writer, tell, listen, pass)+import qualified Control.Monad.Trans.Writer.Strict as Strict (+        WriterT, writer, tell, listen, pass)++import Control.Monad.Trans.Class (lift)+import Control.Monad+import Data.Monoid++-- ---------------------------------------------------------------------------+-- MonadWriter class+--+-- tell is like tell on the MUD's it shouts to monad+-- what you want to be heard. The monad carries this 'packet'+-- upwards, merging it if needed (hence the Monoid requirement).+--+-- listen listens to a monad acting, and returns what the monad "said".+--+-- pass lets you provide a writer transformer which changes internals of+-- the written object.++class (Monoid w, Monad m) => MonadWriter w m | m -> w where+    -- | @'writer' (a,w)@ embeds a simple writer action.+    writer :: (a,w) -> m a+    writer ~(a, w) = do+      tell w+      return a++    -- | @'tell' w@ is an action that produces the output @w@.+    tell   :: w -> m ()+    tell w = writer ((),w)++    -- | @'listen' m@ is an action that executes the action @m@ and adds+    -- its output to the value of the computation.+    listen :: m a -> m (a, w)+    -- | @'pass' m@ is an action that executes the action @m@, which+    -- returns a value and a function, and returns the value, applying+    -- the function to the output.+    pass   :: m (a, w -> w) -> m a++-- | @'listens' f m@ is an action that executes the action @m@ and adds+-- the result of applying @f@ to the output to the value of the computation.+--+-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@+listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)+listens f m = do+    ~(a, w) <- listen m+    return (a, f w)++-- | @'censor' f m@ is an action that executes the action @m@ and+-- applies the function @f@ to its output, leaving the return value+-- unchanged.+--+-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@+censor :: MonadWriter w m => (w -> w) -> m a -> m a+censor f m = pass $ do+    a <- m+    return (a, f)++instance (Monoid w, Monad m) => MonadWriter w (Lazy.WriterT w m) where+    writer = Lazy.writer+    tell   = Lazy.tell+    listen = Lazy.listen+    pass   = Lazy.pass++instance (Monoid w, Monad m) => MonadWriter w (Strict.WriterT w m) where+    writer = Strict.writer+    tell   = Strict.tell+    listen = Strict.listen+    pass   = Strict.pass++instance (Monoid w, Monad m) => MonadWriter w (LazyRWS.RWST r w s m) where+    writer = LazyRWS.writer+    tell   = LazyRWS.tell+    listen = LazyRWS.listen+    pass   = LazyRWS.pass++instance (Monoid w, Monad m) => MonadWriter w (StrictRWS.RWST r w s m) where+    writer = StrictRWS.writer+    tell   = StrictRWS.tell+    listen = StrictRWS.listen+    pass   = StrictRWS.pass++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where+    writer = lift . writer+    tell   = lift . tell+    listen = Error.liftListen listen+    pass   = Error.liftPass pass++instance MonadWriter w m => MonadWriter w (IdentityT m) where+    writer = lift . writer+    tell   = lift . tell+    listen = Identity.mapIdentityT listen+    pass   = Identity.mapIdentityT pass++instance MonadWriter w m => MonadWriter w (MaybeT m) where+    writer = lift . writer+    tell   = lift . tell+    listen = Maybe.liftListen listen+    pass   = Maybe.liftPass pass++instance MonadWriter w m => MonadWriter w (ReaderT r m) where+    writer = lift . writer+    tell   = lift . tell+    listen = mapReaderT listen+    pass   = mapReaderT pass++instance MonadWriter w m => MonadWriter w (Lazy.StateT s m) where+    writer = lift . writer+    tell   = lift . tell+    listen = Lazy.liftListen listen+    pass   = Lazy.liftPass pass++instance MonadWriter w m => MonadWriter w (Strict.StateT s m) where+    writer = lift . writer+    tell   = lift . tell+    listen = Strict.liftListen listen+    pass   = Strict.liftPass pass
+ Control/Monad/Writer/Lazy.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Writer.Lazy+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Lazy writer monads.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.Writer.Lazy (+    -- * MonadWriter class+    MonadWriter(..),+    listens,+    censor,+    -- * The Writer monad+    Writer,+    runWriter,+    execWriter,+    mapWriter,+    -- * The WriterT monad transformer+    WriterT(..),+    execWriterT,+    mapWriterT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    module Data.Monoid,+  ) where++import Control.Monad.Writer.Class++import Control.Monad.Trans+import Control.Monad.Trans.Writer.Lazy (+        Writer, runWriter, execWriter, mapWriter,+        WriterT(..), execWriterT, mapWriterT)++import Control.Monad+import Control.Monad.Fix+import Data.Monoid
+ Control/Monad/Writer/Strict.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Writer.Strict+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (multi-param classes, functional dependencies)+--+-- Strict writer monads.+--+--      Inspired by the paper+--      /Functional Programming with Overloading and Higher-Order Polymorphism/,+--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)+--          Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Control.Monad.Writer.Strict (+    -- * MonadWriter class+    MonadWriter(..),+    listens,+    censor,+    -- * The Writer monad+    Writer,+    runWriter,+    execWriter,+    mapWriter,+    -- * The WriterT monad transformer+    WriterT(..),+    execWriterT,+    mapWriterT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    module Data.Monoid,+  ) where++import Control.Monad.Writer.Class++import Control.Monad.Trans+import Control.Monad.Trans.Writer.Strict (+        Writer, runWriter, execWriter, mapWriter,+        WriterT(..), execWriterT, mapWriterT)++import Control.Monad+import Control.Monad.Fix+import Data.Monoid
+ Data/Functor/Compose.hs view
@@ -0,0 +1,40 @@+-- |+-- Module      :  Data.Functor.Compose+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Composition of functors.++module Data.Functor.Compose (+    Compose(..),+   ) where++import Control.Applicative+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++-- | Right-to-left composition of functors.+-- The composition of applicative functors is always applicative,+-- but the composition of monads is not always a monad.+newtype Compose f g a = Compose { getCompose :: f (g a) }++instance (Functor f, Functor g) => Functor (Compose f g) where+    fmap f (Compose x) = Compose (fmap (fmap f) x)++instance (Foldable f, Foldable g) => Foldable (Compose f g) where+    foldMap f (Compose t) = foldMap (foldMap f) t++instance (Traversable f, Traversable g) => Traversable (Compose f g) where+    traverse f (Compose t) = Compose <$> traverse (traverse f) t++instance (Applicative f, Applicative g) => Applicative (Compose f g) where+    pure x = Compose (pure (pure x))+    Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)++instance (Alternative f, Applicative g) => Alternative (Compose f g) where+    empty = Compose empty+    Compose x <|> Compose y = Compose (x <|> y)
+ Data/Functor/Constant.hs view
@@ -0,0 +1,35 @@+-- |+-- Module      :  Data.Functor.Constant+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The constant functor.++module Data.Functor.Constant (+    Constant(..),+   ) where++import Control.Applicative+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(traverse))++-- | Constant functor.+newtype Constant a b = Constant { getConstant :: a }++instance Functor (Constant a) where+    fmap f (Constant x) = Constant x++instance Foldable (Constant a) where+    foldMap f (Constant x) = mempty++instance Traversable (Constant a) where+    traverse f (Constant x) = pure (Constant x)++instance (Monoid a) => Applicative (Constant a) where+    pure _ = Constant mempty+    Constant x <*> Constant y = Constant (x `mappend` y)
+ Data/Functor/Identity.hs view
@@ -0,0 +1,57 @@+-- |+-- Module      :  Data.Functor.Identity+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- The identity functor and monad.+--+-- This trivial type constructor serves two purposes:+--+-- * It can be used with functions parameterized by functor or monad classes.+--+-- * It can be used as a base monad to which a series of monad+--   transformers may be applied to construct a composite monad.+--   Most monad transformer modules include the special case of+--   applying the transformer to 'Identity'.  For example, @State s@+--   is an abbreviation for @StateT s 'Identity'@.++module Data.Functor.Identity (+    Identity(..),+   ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++-- | Identity functor and monad.+newtype Identity a = Identity { runIdentity :: a }++-- ---------------------------------------------------------------------------+-- Identity instances for Functor and Monad++instance Functor Identity where+    fmap f m = Identity (f (runIdentity m))++instance Foldable Identity where+    foldMap f (Identity x) = f x++instance Traversable Identity where+    traverse f (Identity x) = Identity <$> f x++instance Applicative Identity where+    pure a = Identity a+    Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+    return a = Identity a+    m >>= k  = k (runIdentity m)++instance MonadFix Identity where+    mfix f = Identity (fix (runIdentity . f))
+ Data/Functor/Product.hs view
@@ -0,0 +1,58 @@+-- |+-- Module      :  Data.Functor.Product+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Products, lifted to functors.++module Data.Functor.Product (+    Product(..),+   ) where++import Control.Applicative+import Control.Monad (MonadPlus(..))+import Control.Monad.Fix (MonadFix(..))+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (mappend)+import Data.Traversable (Traversable(traverse))++-- | Lifted product of functors.+data Product f g a = Pair (f a) (g a)++instance (Functor f, Functor g) => Functor (Product f g) where+    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)++instance (Foldable f, Foldable g) => Foldable (Product f g) where+    foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y++instance (Traversable f, Traversable g) => Traversable (Product f g) where+    traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y++instance (Applicative f, Applicative g) => Applicative (Product f g) where+    pure x = Pair (pure x) (pure x)+    Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)++instance (Alternative f, Alternative g) => Alternative (Product f g) where+    empty = Pair empty empty+    Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)++instance (Monad f, Monad g) => Monad (Product f g) where+    return x = Pair (return x) (return x)+    Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)+      where+        fstP (Pair a _) = a+        sndP (Pair _ b) = b++instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where+    mzero = Pair mzero mzero+    Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)++instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where+    mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))+      where+        fstP (Pair a _) = a+        sndP (Pair _ b) = b
+ Data/Functor/Reverse.hs view
@@ -0,0 +1,54 @@+-- |+-- Module      :  Data.Functor.Reverse+-- Copyright   :  (c) Russell O'Connor 2009+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Making functors whose elements are notionally in the reverse order+-- from the original functor.++module Data.Functor.Reverse where++import Control.Applicative.Backwards++import Prelude hiding (foldr, foldr1, foldl, foldl1)+import Control.Applicative+import Data.Foldable+import Data.Traversable+import Data.Monoid++-- | The same functor, but with 'Foldable' and 'Traversable' instances+-- that process the elements in the reverse order.+newtype Reverse f a = Reverse { getReverse :: f a }++-- | Derived instance.+instance (Functor f) => Functor (Reverse f) where+    fmap f (Reverse a) = Reverse (fmap f a)++-- | Derived instance.+instance (Applicative f) => Applicative (Reverse f) where+    pure a = Reverse (pure a)+    Reverse f <*> Reverse a = Reverse (f <*> a)++-- | Derived instance.+instance (Alternative f) => Alternative (Reverse f) where+    empty = Reverse empty+    Reverse x <|> Reverse y = Reverse (x <|> y)++-- | Fold from right to left.+instance (Foldable f) => Foldable (Reverse f) where+    foldMap f (Reverse t) = getDual (foldMap (Dual . f) t)+    foldr f z (Reverse t) = foldl (flip f) z t+    foldl f z (Reverse t) = foldr (flip f) z t+    foldr1 f (Reverse t) = foldl1 (flip f) t+    foldl1 f (Reverse t) = foldr1 (flip f) t++-- | Traverse from right to left.+instance (Traversable f) => Traversable (Reverse f) where+    traverse f (Reverse t) =+        fmap Reverse . forwards $ traverse (Backwards . f) t+    sequenceA (Reverse t) =+        fmap Reverse . forwards $ sequenceA (fmap Backwards t)
+ Distribution/Client/BuildReports/Anonymous.hs view
@@ -0,0 +1,311 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Anonymous (+    BuildReport(..),+    InstallOutcome(..),+    Outcome(..),++    -- * Constructing and writing reports+    new,++    -- * parsing and pretty printing+    parse,+    parseList,+    show,+--    showList,+  ) where++import Distribution.Client.Types+         ( ConfiguredPackage(..) )+import qualified Distribution.Client.Types as BR+         ( BuildResult, BuildFailure(..), BuildSuccess(..)+         , DocsResult(..), TestsResult(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import qualified Paths_cabal_install_bundle (version)++import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(packageId) )+import Distribution.PackageDescription+         ( FlagName(..), FlagAssignment )+--import Distribution.Version+--         ( Version )+import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId )+import qualified Distribution.Text as Text+         ( Text(disp, parse) )+import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), Field(..)+         , simpleField, listField, ppFields, readFields+         , syntaxError, locatedErrorMsg )+import Distribution.Simple.Utils+         ( comparing )++import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, pfail, munch1, skipSpaces )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, char, text )+import Text.PrettyPrint.HughesPJ+         ( (<+>), (<>) )++import Data.List+         ( unfoldr, sortBy )+import Data.Char as Char+         ( isAlpha, isAlphaNum )++import Prelude hiding (show)++data BuildReport+   = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }++data InstallOutcome+   = DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | InstallFailed+   | InstallOk+  deriving Eq++data Outcome = NotTried | Failed | Ok+  deriving Eq++new :: OS -> Arch -> CompilerId -- -> Version+    -> ConfiguredPackage -> BR.BuildResult+    -> BuildReport+new os' arch' comp (ConfiguredPackage pkg flags deps) result =+  BuildReport {+    package               = packageId pkg,+    os                    = os',+    arch                  = arch',+    compiler              = comp,+    client                = cabalInstallID,+    flagAssignment        = flags,+    dependencies          = deps,+    installOutcome        = convertInstallOutcome,+--    cabalVersion          = undefined+    docsOutcome           = convertDocsOutcome,+    testsOutcome          = convertTestsOutcome+  }+  where+    convertInstallOutcome = case result of+      Left  (BR.DependentFailed p) -> DependencyFailed p+      Left  (BR.DownloadFailed  _) -> DownloadFailed+      Left  (BR.UnpackFailed    _) -> UnpackFailed+      Left  (BR.ConfigureFailed _) -> ConfigureFailed+      Left  (BR.BuildFailed     _) -> BuildFailed+      Left  (BR.InstallFailed   _) -> InstallFailed+      Right (BR.BuildOk       _ _) -> InstallOk+    convertDocsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk BR.DocsNotTried _)  -> NotTried+      Right (BR.BuildOk BR.DocsFailed _)    -> Failed+      Right (BR.BuildOk BR.DocsOk _)        -> Ok+    convertTestsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried+      Right (BR.BuildOk _ BR.TestsFailed)   -> Failed+      Right (BR.BuildOk _ BR.TestsOk)       -> Ok++cabalInstallID :: PackageIdentifier+cabalInstallID =+  PackageIdentifier (PackageName "cabal-install") Paths_cabal_install_bundle.version++-- ------------------------------------------------------------+-- * External format+-- ------------------------------------------------------------++initialBuildReport :: BuildReport+initialBuildReport = BuildReport {+    package         = requiredField "package",+    os              = requiredField "os",+    arch            = requiredField "arch",+    compiler        = requiredField "compiler",+    client          = requiredField "client",+    flagAssignment  = [],+    dependencies    = [],+    installOutcome  = requiredField "install-outcome",+--    cabalVersion  = Nothing,+--    tools         = [],+    docsOutcome     = NotTried,+    testsOutcome    = NotTried+  }+  where+    requiredField fname = error ("required field: " ++ fname)++-- -----------------------------------------------------------------------------+-- Parsing++parse :: String -> Either String BuildReport+parse s = case parseFields s of+  ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror+  ParseOk   _ report -> Right report++--FIXME: this does not allow for optional or repeated fields+parseFields :: String -> ParseResult BuildReport+parseFields input = do+  fields <- mapM extractField =<< readFields input+  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)+                       sortedFieldDescrs+                       (sortBy (comparing (\(_,name,_) -> name)) fields)+  checkMerged initialBuildReport merged++  where+    extractField :: Field -> ParseResult (Int, String, String)+    extractField (F line name value)  = return (line, name, value)+    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"+    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"++    checkMerged report [] = return report+    checkMerged report (merged:remaining) = case merged of+      InBoth fieldDescr (line, _name, value) -> do+        report' <- fieldSet fieldDescr line value report+        checkMerged report' remaining+      OnlyInRight (line, name, _) ->+        syntaxError line ("Unrecognized field " ++ name)+      OnlyInLeft  fieldDescr ->+        fail ("Missing field " ++ fieldName fieldDescr)++parseList :: String -> [BuildReport]+parseList str =+  [ report | Right report <- map parse (split str) ]++  where+    split :: String -> [String]+    split = filter (not . null) . unfoldr chunk . lines+    chunk [] = Nothing+    chunk ls = case break null ls of+                 (r, rs) -> Just (unlines r, dropWhile null rs)++-- -----------------------------------------------------------------------------+-- Pretty-printing++show :: BuildReport -> String+show = Disp.render . ppFields fieldDescrs++-- -----------------------------------------------------------------------------+-- Description of the fields, for parsing/printing++fieldDescrs :: [FieldDescr BuildReport]+fieldDescrs =+ [ simpleField "package"         Text.disp      Text.parse+                                 package        (\v r -> r { package = v })+ , simpleField "os"              Text.disp      Text.parse+                                 os             (\v r -> r { os = v })+ , simpleField "arch"            Text.disp      Text.parse+                                 arch           (\v r -> r { arch = v })+ , simpleField "compiler"        Text.disp      Text.parse+                                 compiler       (\v r -> r { compiler = v })+ , simpleField "client"          Text.disp      Text.parse+                                 client         (\v r -> r { client = v })+ , listField   "flags"           dispFlag       parseFlag+                                 flagAssignment (\v r -> r { flagAssignment = v })+ , listField   "dependencies"    Text.disp      Text.parse+                                 dependencies   (\v r -> r { dependencies = v })+ , simpleField "install-outcome" Text.disp      Text.parse+                                 installOutcome (\v r -> r { installOutcome = v })+ , simpleField "docs-outcome"    Text.disp      Text.parse+                                 docsOutcome    (\v r -> r { docsOutcome = v })+ , simpleField "tests-outcome"   Text.disp      Text.parse+                                 testsOutcome   (\v r -> r { testsOutcome = v })+ ]++sortedFieldDescrs :: [FieldDescr BuildReport]+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs++dispFlag :: (FlagName, Bool) -> Disp.Doc+dispFlag (FlagName name, True)  =                  Disp.text name+dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name++parseFlag :: Parse.ReadP r (FlagName, Bool)+parseFlag = do+  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')+  case name of+    ('-':flag) -> return (FlagName flag, False)+    flag       -> return (FlagName flag, True)++instance Text.Text InstallOutcome where+  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid+  disp DownloadFailed  = Disp.text "DownloadFailed"+  disp UnpackFailed    = Disp.text "UnpackFailed"+  disp SetupFailed     = Disp.text "SetupFailed"+  disp ConfigureFailed = Disp.text "ConfigureFailed"+  disp BuildFailed     = Disp.text "BuildFailed"+  disp InstallFailed   = Disp.text "InstallFailed"+  disp InstallOk       = Disp.text "InstallOk"++  parse = do+    name <- Parse.munch1 Char.isAlphaNum+    case name of+      "DependencyFailed" -> do Parse.skipSpaces+                               pkgid <- Text.parse+                               return (DependencyFailed pkgid)+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> Parse.pfail++instance Text.Text Outcome where+  disp NotTried = Disp.text "NotTried"+  disp Failed   = Disp.text "Failed"+  disp Ok       = Disp.text "Ok"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> Parse.pfail
+ Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Storage (++    -- * Storing and retrieving build reports+    storeAnonymous,+    storeLocal,+--    retrieve,++    -- * 'InstallPlan' support+    fromInstallPlan,+  ) where++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)++import Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( InstallPlan )++import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , initialPathTemplateEnv, substPathTemplate )+import Distribution.System+         ( Platform(Platform) )+import Distribution.Compiler+         ( CompilerId )+import Distribution.Simple.Utils+         ( comparing, equating )++import Data.List+         ( groupBy, sortBy )+import Data.Maybe+         ( catMaybes )+import System.FilePath+         ( (</>), takeDirectory )+import System.Directory+         ( createDirectoryIfMissing )++storeAnonymous :: [(BuildReport, Repo)] -> IO ()+storeAnonymous reports = sequence_+  [ appendFile file (concatMap format reports')+  | (repo, reports') <- separate reports+  , let file = repoLocalDir repo </> "build-reports.log" ]+  --TODO: make this concurrency safe, either lock the report file or make sure+  -- the writes for each report are atomic (under 4k and flush at boundaries)++  where+    format r = '\n' : BuildReport.show r ++ "\n"+    separate :: [(BuildReport, Repo)]+             -> [(Repo, [BuildReport])]+    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))+             . map concat+             . groupBy (equating (repoName . head))+             . sortBy (comparing (repoName . head))+             . groupBy (equating repoName)+             . onlyRemote+    repoName (_,_,rrepo) = remoteRepoName rrepo++    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote rs =+      [ (report, repo, remoteRepo)+      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]++storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()+storeLocal templates reports = sequence_+  [ do createDirectoryIfMissing True (takeDirectory file)+       appendFile file output+       --TODO: make this concurrency safe, either lock the report file or make+       --      sure the writes for each report are atomic+  | (file, reports') <- groupByFileName+                          [ (reportFileName template report, report)+                          | template <- templates+                          , (report, _repo) <- reports ]+  , let output = concatMap format reports'+  ]+  where+    format r = '\n' : BuildReport.show r ++ "\n"++    reportFileName template report =+        fromPathTemplate (substPathTemplate env template)+      where env = initialPathTemplateEnv+                    (BuildReport.package  report)+                    (BuildReport.compiler report)++    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))+                    . groupBy (equating  fst)+                    . sortBy  (comparing fst)++-- ------------------------------------------------------------+-- * InstallPlan support+-- ------------------------------------------------------------++fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]+fromInstallPlan plan = catMaybes+                     . map (fromPlanPackage platform comp)+                     . InstallPlan.toList+                     $ plan+  where platform = InstallPlan.planPlatform plan+        comp     = InstallPlan.planCompiler plan++fromPlanPackage :: Platform -> CompilerId+                -> InstallPlan.PlanPackage+                -> Maybe (BuildReport, Repo)+fromPlanPackage (Platform arch os) comp planPackage = case planPackage of++  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {+                          packageSource = RepoTarballPackage repo _ _ }) _ _) result+    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)++  InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {+                       packageSource = RepoTarballPackage repo _ _ }) _ _) result+    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)++  _ -> Nothing
+ Distribution/Client/BuildReports/Types.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildReports.Types+-- Copyright   :  (c) Duncan Coutts 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Types related to build reporting+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Types (+    ReportLevel(..),+  ) where++import qualified Distribution.Text as Text+         ( Text(..) )++import qualified Distribution.Compat.ReadP as Parse+         ( pfail, munch1 )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( text )++import Data.Char as Char+         ( isAlpha, toLower )++data ReportLevel = NoReports | AnonymousReports | DetailedReports+  deriving (Eq, Ord, Show)++instance Text.Text ReportLevel where+  disp NoReports        = Disp.text "none"+  disp AnonymousReports = Disp.text "anonymous"+  disp DetailedReports  = Disp.text "detailed"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case lowercase name of+      "none"       -> return NoReports+      "anonymous"  -> return AnonymousReports+      "detailed"   -> return DetailedReports+      _            -> Parse.pfail++lowercase :: String -> String+lowercase = map Char.toLower
+ Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PatternGuards #-}+-- This is a quick hack for uploading build reports to Hackage.++module Distribution.Client.BuildReports.Upload+    ( BuildLog+    , BuildReportId+    , uploadReports+    , postBuildReport+    , putBuildLog+    ) where++import Network.Browser+         ( BrowserAction, request, setAllowRedirects )+import Network.HTTP+         ( Header(..), HeaderName(..)+         , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream)+import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)++import Control.Monad+         ( forM_ )+import System.FilePath.Posix+         ( (</>) )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)+import Distribution.Text (display)++type BuildReportId = URI+type BuildLog = String++uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]+              -> BrowserAction (HandleStream String) ()+              ->  BrowserAction (HandleStream BuildLog) ()+uploadReports uri reports auth = do+  auth+  forM_ reports $ \(report, mbBuildLog) -> do+     buildId <- postBuildReport uri report+     case mbBuildLog of+       Just buildLog -> putBuildLog buildId buildLog+       Nothing       -> return ()++postBuildReport :: URI -> BuildReport+                -> BrowserAction (HandleStream BuildLog) BuildReportId+postBuildReport uri buildReport = do+  setAllowRedirects False+  (_, response) <- request Request {+    rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },+    rqMethod  = POST,+    rqHeaders = [Header HdrContentType   ("text/plain"),+                 Header HdrContentLength (show (length body)),+                 Header HdrAccept        ("text/plain")],+    rqBody    = body+  }+  case rspCode response of+    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+                                     relativeTo rel uri+                                  | Header HdrLocation location <- rspHeaders response ]+              -> return $ buildId+    _         -> error "Unrecognised response from server."+  where body  = BuildReport.show buildReport++putBuildLog :: BuildReportId -> BuildLog+            -> BrowserAction (HandleStream BuildLog) ()+putBuildLog reportId buildLog = do+  --FIXME: do something if the request fails+  (_, response) <- request Request {+      rqURI     = reportId{uriPath = uriPath reportId </> "log"},+      rqMethod  = PUT,+      rqHeaders = [Header HdrContentType   ("text/plain"),+                   Header HdrContentLength (show (length buildLog)),+                   Header HdrAccept        ("text/plain")],+      rqBody    = buildLog+    }+  return ()
+ Distribution/Client/Check.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Check+-- Copyright   :  (c) Lennart Kolmodin 2008+-- License     :  BSD-like+--+-- Maintainer  :  kolmodin@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Check a package for common mistakes+--+-----------------------------------------------------------------------------+module Distribution.Client.Check (+    check+  ) where++import Control.Monad ( when, unless )++import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.Check+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( defaultPackageDesc, toUTF8, wrapText )++check :: Verbosity -> IO Bool+check verbosity = do+    pdfile <- defaultPackageDesc verbosity+    ppd <- readPackageDescription verbosity pdfile+    -- flatten the generic package description into a regular package+    -- description+    -- TODO: this may give more warnings than it should give;+    --       consider two branches of a condition, one saying+    --          ghc-options: -Wall+    --       and the other+    --          ghc-options: -Werror+    --      joined into+    --          ghc-options: -Wall -Werror+    --      checkPackages will yield a warning on the last line, but it+    --      would not on each individual branch.+    --      Hovever, this is the same way hackage does it, so we will yield+    --      the exact same errors as it will.+    let pkg_desc = flattenPackageDescription ppd+    ioChecks <- checkPackageFiles pkg_desc "."+    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)+        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]+        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]+        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]++    unless (null buildImpossible) $ do+        putStrLn "The package will not build sanely due to these errors:"+        printCheckMessages buildImpossible++    unless (null buildWarning) $ do+        putStrLn "The following warnings are likely affect your build negatively:"+        printCheckMessages buildWarning++    unless (null distSuspicious) $ do+        putStrLn "These warnings may cause trouble when distributing the package:"+        printCheckMessages distSuspicious++    unless (null distInexusable) $ do+        putStrLn "The following errors will cause portability problems on other environments:"+        printCheckMessages distInexusable++    let isDistError (PackageDistSuspicious {}) = False+        isDistError _                          = True+        errors = filter isDistError packageChecks++    unless (null errors) $ do+        putStrLn "Hackage would reject this package."++    when (null packageChecks) $ do+        putStrLn "No errors or warnings could be found in the package."++    return (null packageChecks)++  where+    printCheckMessages = mapM_ (putStrLn . format . explanation)+    format = toUTF8 . wrapText . ("* "++)
+ Distribution/Client/Config.hs view
@@ -0,0 +1,532 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Config+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for handling saved state such as known packages, known servers and downloaded packages.+-----------------------------------------------------------------------------+module Distribution.Client.Config (+    SavedConfig(..),+    loadConfig,++    showConfig,+    showConfigWithComments,+    parseConfig,++    defaultCabalDir,+    defaultConfigFile,+    defaultCacheDir,+    defaultLogsDir,+  ) where+++import Distribution.Client.Types+         ( RemoteRepo(..), Username(..), Password(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , InstallFlags(..), installOptions, defaultInstallFlags+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , showRepo, parseRepo )++import Distribution.Simple.Setup+         ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , installDirsOptions+         , Flag, toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.InstallDirs+         ( InstallDirs(..), defaultInstallDirs+         , PathTemplate, toPathTemplate )+import Distribution.ParseUtils+         ( FieldDescr(..), liftField+         , ParseResult(..), locatedErrorMsg, showPWarning+         , readFields, warning, lineNo+         , simpleField, listField, parseFilePathQ, parseTokenQ )+import qualified Distribution.ParseUtils as ParseUtils+         ( Field(..) )+import qualified Distribution.Text as Text+         ( Text(..) )+import Distribution.Simple.Command+         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)+         , viewAsFieldDescr )+import Distribution.Simple.Program+         ( defaultProgramConfiguration )+import Distribution.Simple.Utils+         ( notice, warn, lowercase )+import Distribution.Compiler+         ( CompilerFlavor(..), defaultCompilerFlavor )+import Distribution.Verbosity+         ( Verbosity, normal )++import Data.List+         ( partition, find )+import Data.Maybe+         ( fromMaybe )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( when, foldM, liftM )+import qualified Data.Map as Map+import qualified Distribution.Compat.ReadP as Parse+         ( option )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, text, colon, vcat, empty, isEmpty, nest )+import Text.PrettyPrint.HughesPJ+         ( (<>), (<+>), ($$), ($+$) )+import System.Directory+         ( createDirectoryIfMissing, getAppUserDataDirectory )+import Network.URI+         ( URI(..), URIAuth(..) )+import System.FilePath+         ( (</>), takeDirectory )+import System.Environment+         ( getEnvironment )+import System.IO.Error+         ( isDoesNotExistError )++--+-- * Configuration saved in the config file+--++data SavedConfig = SavedConfig {+    savedGlobalFlags       :: GlobalFlags,+    savedInstallFlags      :: InstallFlags,+    savedConfigureFlags    :: ConfigFlags,+    savedConfigureExFlags  :: ConfigExFlags,+    savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),+    savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),+    savedUploadFlags       :: UploadFlags,+    savedReportFlags       :: ReportFlags+  }++instance Monoid SavedConfig where+  mempty = SavedConfig {+    savedGlobalFlags       = mempty,+    savedInstallFlags      = mempty,+    savedConfigureFlags    = mempty,+    savedConfigureExFlags  = mempty,+    savedUserInstallDirs   = mempty,+    savedGlobalInstallDirs = mempty,+    savedUploadFlags       = mempty,+    savedReportFlags       = mempty+  }+  mappend a b = SavedConfig {+    savedGlobalFlags       = combine savedGlobalFlags,+    savedInstallFlags      = combine savedInstallFlags,+    savedConfigureFlags    = combine savedConfigureFlags,+    savedConfigureExFlags  = combine savedConfigureExFlags,+    savedUserInstallDirs   = combine savedUserInstallDirs,+    savedGlobalInstallDirs = combine savedGlobalInstallDirs,+    savedUploadFlags       = combine savedUploadFlags,+    savedReportFlags       = combine savedReportFlags+  }+    where combine field = field a `mappend` field b++updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig+updateInstallDirs userInstallFlag+  savedConfig@SavedConfig {+    savedConfigureFlags    = configureFlags,+    savedUserInstallDirs   = userInstallDirs,+    savedGlobalInstallDirs = globalInstallDirs+  } =+  savedConfig {+    savedConfigureFlags = configureFlags {+      configInstallDirs = installDirs+    }+  }+  where+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall $+                    configUserInstall configureFlags `mappend` userInstallFlag++--+-- * Default config+--++-- | These are the absolute basic defaults. The fields that must be+-- initialised. When we load the config from the file we layer the loaded+-- values over these ones, so any missing fields in the file take their values+-- from here.+--+baseSavedConfig :: IO SavedConfig+baseSavedConfig = do+  userPrefix <- defaultCabalDir+  logsDir    <- defaultLogsDir+  worldFile  <- defaultWorldFile+  return mempty {+    savedConfigureFlags  = mempty {+      configHcFlavor     = toFlag defaultCompiler,+      configUserInstall  = toFlag defaultUserInstall,+      configVerbosity    = toFlag normal+    },+    savedUserInstallDirs = mempty {+      prefix             = toFlag (toPathTemplate userPrefix)+    },+    savedGlobalFlags = mempty {+      globalLogsDir      = toFlag logsDir,+      globalWorldFile    = toFlag worldFile+    }+  }++-- | This is the initial configuration that we write out to to the config file+-- if the file does not exist (or the config we use if the file cannot be read+-- for some other reason). When the config gets loaded it gets layered on top+-- of 'baseSavedConfig' so we do not need to include it into the initial+-- values we save into the config file.+--+initialSavedConfig :: IO SavedConfig+initialSavedConfig = do+  cacheDir   <- defaultCacheDir+  logsDir    <- defaultLogsDir+  worldFile  <- defaultWorldFile+  return mempty {+    savedGlobalFlags     = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalRemoteRepos  = [defaultRemoteRepo],+      globalWorldFile    = toFlag worldFile+    },+    savedInstallFlags    = mempty {+      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],+      installBuildReports= toFlag AnonymousReports+    }+  }++--TODO: misleading, there's no way to override this default+--      either make it possible or rename to simply getCabalDir.+defaultCabalDir :: IO FilePath+defaultCabalDir = getAppUserDataDirectory "cabal"++defaultConfigFile :: IO FilePath+defaultConfigFile = do+  dir <- defaultCabalDir+  return $ dir </> "config"++defaultCacheDir :: IO FilePath+defaultCacheDir = do+  dir <- defaultCabalDir+  return $ dir </> "packages"++defaultLogsDir :: IO FilePath+defaultLogsDir = do+  dir <- defaultCabalDir+  return $ dir </> "logs"++-- | Default position of the world file+defaultWorldFile :: IO FilePath+defaultWorldFile = do+  dir <- defaultCabalDir+  return $ dir </> "world"++defaultCompiler :: CompilerFlavor+defaultCompiler = fromMaybe GHC defaultCompilerFlavor++defaultUserInstall :: Bool+defaultUserInstall = True+-- We do per-user installs by default on all platforms. We used to default to+-- global installs on Windows but that no longer works on Windows Vista or 7.++defaultRemoteRepo :: RemoteRepo+defaultRemoteRepo = RemoteRepo name uri+  where+    name = "hackage.haskell.org"+    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""++--+-- * Config file reading+--++loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig+loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do+  let sources = [+        ("commandline option",   return . flagToMaybe $ configFileFlag),+        ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),+        ("default config file",  Just `liftM` defaultConfigFile) ]++      getSource [] = error "no config file path candidate found."+      getSource ((msg,action): xs) = +                        action >>= maybe (getSource xs) (return . (,) msg)++  (source, configFile) <- getSource sources+  minp <- readConfigFile mempty configFile+  case minp of+    Nothing -> do+      notice verbosity $ "Config file path source is " ++ source ++ "."+      notice verbosity $ "Config file " ++ configFile ++ " not found."+      notice verbosity $ "Writing default configuration to " ++ configFile+      commentConf <- commentSavedConfig+      initialConf <- initialSavedConfig+      writeConfigFile configFile commentConf initialConf+      return initialConf+    Just (ParseOk ws conf) -> do+      when (not $ null ws) $ warn verbosity $+        unlines (map (showPWarning configFile) ws)+      return conf+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $+          "Error parsing config file " ++ configFile+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg+      warn verbosity $ "Using default configuration."+      initialSavedConfig++  where+    addBaseConf body = do+      base  <- baseSavedConfig+      extra <- body+      return (updateInstallDirs userInstallFlag (base `mappend` extra))++readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))+readConfigFile initial file = handleNotExists $+  fmap (Just . parseConfig initial) (readFile file)++  where+    handleNotExists action = catch action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()+writeConfigFile file comments vals = do+  createDirectoryIfMissing True (takeDirectory file)+  writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"+  where+    explanation = unlines+      ["-- This is the configuration file for the 'cabal' command line tool."+      ,""+      ,"-- The available configuration options are listed below."+      ,"-- Some of them have default values listed."+      ,""+      ,"-- Lines (like this one) beginning with '--' are comments."+      ,"-- Be careful with spaces and indentation because they are"+      ,"-- used to indicate layout for nested sections."+      ,"",""+      ]++-- | These are the default values that get used in Cabal if a no value is+-- given. We use these here to include in comments when we write out the+-- initial config file so that the user can see what default value they are+-- overriding.+--+commentSavedConfig :: IO SavedConfig+commentSavedConfig = do+  userInstallDirs   <- defaultInstallDirs defaultCompiler True True+  globalInstallDirs <- defaultInstallDirs defaultCompiler False True+  return SavedConfig {+    savedGlobalFlags       = commandDefaultFlags globalCommand,+    savedInstallFlags      = defaultInstallFlags,+    savedConfigureExFlags  = defaultConfigExFlags,+    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {+      configUserInstall    = toFlag defaultUserInstall+    },+    savedUserInstallDirs   = fmap toFlag userInstallDirs,+    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+    savedUploadFlags       = commandDefaultFlags uploadCommand,+    savedReportFlags       = commandDefaultFlags reportCommand+  }++-- | All config file fields.+--+configFieldDescriptions :: [FieldDescr SavedConfig]+configFieldDescriptions =++     toSavedConfig liftGlobalFlag+       (commandOptions globalCommand ParseArgs)+       ["version", "numeric-version", "config-file"] []++  ++ toSavedConfig liftConfigFlag+       (configureOptions ParseArgs)+       (["builddir", "configure-option"] ++ map fieldName installDirsFields)++        --FIXME: this is only here because viewAsFieldDescr gives us a parser+        -- that only recognises 'ghc' etc, the case-sensitive flag names, not+        -- what the normal case-insensitive parser gives us.+       [simpleField "compiler"+          (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)+          configHcFlavor (\v flags -> flags { configHcFlavor = v })+       ]++  ++ toSavedConfig liftConfigExFlag+       (configureExOptions ParseArgs)+       [] []++  ++ toSavedConfig liftInstallFlag+       (installOptions ParseArgs)+       ["dry-run", "reinstall", "only"] []++  ++ toSavedConfig liftUploadFlag+       (commandOptions uploadCommand ParseArgs)+       ["verbose", "check"] []++  ++ toSavedConfig liftReportFlag+       (commandOptions reportCommand ParseArgs)+       ["verbose"] []++  where+    toSavedConfig lift options exclusions replacements =+      [ lift (fromMaybe field replacement)+      | opt <- options+      , let field       = viewAsFieldDescr opt+            name        = fieldName field+            replacement = find ((== name) . fieldName) replacements+      , name `notElem` exclusions ]+    optional = Parse.option mempty . fmap toFlag++-- TODO: next step, make the deprecated fields elicit a warning.+--+deprecatedFieldDescriptions :: [FieldDescr SavedConfig]+deprecatedFieldDescriptions =+  [ liftGlobalFlag $+    listField "repos"+      (Disp.text . showRepo) parseRepo+      globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })+  , liftGlobalFlag $+    simpleField "cachedir"+      (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)+      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })+  , liftUploadFlag $+    simpleField "hackage-username"+      (Disp.text . fromFlagOrDefault "" . fmap unUsername)+      (optional (fmap Username parseTokenQ))+      uploadUsername    (\d cfg -> cfg { uploadUsername = d })+  , liftUploadFlag $+    simpleField "hackage-password"+      (Disp.text . fromFlagOrDefault "" . fmap unPassword)+      (optional (fmap Password parseTokenQ))+      uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  ]+ ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields+ ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields+  where+    optional = Parse.option mempty . fmap toFlag+    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a+    modifyFieldName f d = d { fieldName = f (fieldName d) }++liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                    -> FieldDescr SavedConfig+liftUserInstallDirs = liftField+  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })++liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                      -> FieldDescr SavedConfig+liftGlobalInstallDirs = liftField+  savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })++liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig+liftGlobalFlag = liftField+  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })++liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig+liftConfigFlag = liftField+  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })++liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig+liftConfigExFlag = liftField+  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })++liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig+liftInstallFlag = liftField+  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })++liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig+liftUploadFlag = liftField+  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })++liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig+liftReportFlag = liftField+  savedReportFlags (\flags conf -> conf { savedReportFlags = flags })++parseConfig :: SavedConfig -> String -> ParseResult SavedConfig+parseConfig initial = \str -> do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  config <- parse others+  let user0   = savedUserInstallDirs config+      global0 = savedGlobalInstallDirs config+  (user, global) <- foldM parseSections (user0, global0) knownSections+  return config {+    savedUserInstallDirs   = user,+    savedGlobalInstallDirs = global+  }++  where+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True+    isKnownSection _                                          = False++    parse = parseFields (configFieldDescriptions+                      ++ deprecatedFieldDescriptions) initial++    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)+      | name' == "user"   = do u' <- parseFields installDirsFields u fs+                               return (u', g)+      | name' == "global" = do g' <- parseFields installDirsFields g fs+                               return (u, g')+      | otherwise         = do+          warning "The install-paths section should be for 'user' or 'global'"+          return accum+      where name' = lowercase name+    parseSections accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++showConfig :: SavedConfig -> String+showConfig = showConfigWithComments mempty++showConfigWithComments :: SavedConfig -> SavedConfig -> String+showConfigWithComments comment vals = Disp.render $+      ppFields configFieldDescriptions comment vals+  $+$ Disp.text ""+  $+$ installDirsSection "user"   savedUserInstallDirs+  $+$ Disp.text ""+  $+$ installDirsSection "global" savedGlobalInstallDirs+  where+    installDirsSection name field =+      ppSection "install-dirs" name installDirsFields+                (field comment) (field vals)++------------------------+-- * Parsing utils+--++--FIXME: replace this with something better in Cabal-1.5+parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a+parseFields fields initial = foldM setField initial+  where+    fieldMap = Map.fromList+      [ (name, f) | f@(FieldDescr name _ _) <- fields ]+    setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of+      Just (FieldDescr _ _ set) -> set line value accum+      Nothing -> do+        warning $ "Unrecognized field " ++ name ++ " on line " ++ show line+        return accum+    setField accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++-- | This is a customised version of the function from Cabal that also prints+-- default values for empty fields as comments.+--+ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc+ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)+                                    | FieldDescr name getter _ <- fields]++ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc+ppField name def cur+  | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def+  | otherwise        =                    Disp.text name <> Disp.colon <+> cur++ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc+ppSection name arg fields def cur =+     Disp.text name <+> Disp.text arg+  $$ Disp.nest 2 (ppFields fields def cur)++installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]+installDirsFields = map viewAsFieldDescr installDirsOptions+
+ Distribution/Client/Configure.hs view
@@ -0,0 +1,191 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Configure+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Duncan Coutts 2005+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- High level interface to configuring a package.+-----------------------------------------------------------------------------+module Distribution.Client.Configure (+    configure,+  ) where++import Distribution.Client.Dependency+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, getInstalledPackages )+import Distribution.Client.Setup+         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )+import Distribution.Client.Types as Available+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId)+         , PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration )+import Distribution.Simple.Setup+         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Simple.Utils+         ( defaultPackageDesc )+import Distribution.Package+         ( Package(..), packageName, Dependency(..), thisPackageVersion )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Version+         ( anyVersion, thisVersion )+import Distribution.Simple.Utils as Utils+         ( notice, info, debug, die )+import Distribution.System+         ( Platform, buildPlatform )+import Distribution.Verbosity as Verbosity+         ( Verbosity )++import Data.Monoid (Monoid(..))++-- | Configure the package found in the local directory+configure :: Verbosity+          -> PackageDBStack+          -> [Repo]+          -> Compiler+          -> ProgramConfiguration+          -> ConfigFlags+          -> ConfigExFlags+          -> [String]+          -> IO ()+configure verbosity packageDBs repos comp conf+  configFlags configExFlags extraArgs = do++  installed <- getInstalledPackages verbosity comp packageDBs conf+  available <- getAvailablePackages verbosity repos++  progress <- planLocalPackage verbosity comp configFlags configExFlags+                               installed available++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress logMsg (return . Left) (return . Right)+                            progress+  case maybePlan of+    Left message -> do+      info verbosity message+      setupWrapper verbosity (setupScriptOptions installed) Nothing+        configureCommand (const configFlags) extraArgs++    Right installPlan -> case InstallPlan.ready installPlan of+      [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->+        configurePackage verbosity+          (InstallPlan.planPlatform installPlan)+          (InstallPlan.planCompiler installPlan)+          (setupScriptOptions installed)+          configFlags pkg extraArgs++      _ -> die $ "internal error: configure install plan should have exactly "+              ++ "one local ready package."++  where+    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe anyVersion thisVersion+                         (flagToMaybe (configCabalVersion configExFlags)),+      useCompiler      = Just comp,+      -- Hack: we typically want to allow the UserPackageDB for finding the+      -- Cabal lib when compiling any Setup.hs even if we're doing a global+      -- install. However we also allow looking in a specific package db.+      usePackageDB     = if UserPackageDB `elem` packageDBs+                           then packageDBs+                           else packageDBs ++ [UserPackageDB],+      usePackageIndex  = if UserPackageDB `elem` packageDBs+                           then Just index+                           else Nothing,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }++    logMsg message rest = debug verbosity message >> rest++-- | Make an 'InstallPlan' for the unpacked package in the current directory,+-- and all its dependencies.+--+planLocalPackage :: Verbosity -> Compiler+                 -> ConfigFlags -> ConfigExFlags+                 -> PackageIndex InstalledPackage+                 -> AvailablePackageDb+                 -> IO (Progress String String InstallPlan)+planLocalPackage verbosity comp configFlags configExFlags installed+  (AvailablePackageDb _ availablePrefs) = do+  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity++  let -- We create a local package and ask to resolve a dependency on it+      localPkg = AvailablePackage {+        packageInfoId                = packageId pkg,+        Available.packageDescription = pkg,+        packageSource                = LocalUnpackedPackage "."+      }++      resolverParams =++          addPreferences+            -- preferences from the config file or command line+            [ PackageVersionPreference name ver+            | Dependency name ver <- configPreferences configExFlags ]++        . addConstraints+            -- version constraints from the config file or command line+            [ PackageVersionConstraint name ver+            | Dependency name ver <- configConstraints configFlags ]++        . addConstraints+            -- package flags from the config file or command line+            [ PackageFlagsConstraint (packageName pkg)+                                     (configConfigurationsFlags configFlags) ]++        $ standardInstallPolicy+            installed+            (AvailablePackageDb mempty availablePrefs)+            [SpecificSourcePackage localPkg]++  return (resolveDependencies buildPlatform (compilerId comp) resolverParams)+++-- | Call an installer for an 'AvailablePackage' but override the configure+-- flags with the ones given by the 'ConfiguredPackage'. In particular the+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- versioned package dependencies. So we ignore any previous partial flag+-- assignment or dependency constraints and use the new ones.+--+configurePackage :: Verbosity+                 -> Platform -> CompilerId+                 -> SetupScriptOptions+                 -> ConfigFlags+                 -> ConfiguredPackage+                 -> [String]+                 -> IO ()+configurePackage verbosity platform comp scriptOptions configFlags+  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =++  setupWrapper verbosity+    scriptOptions (Just pkg) configureCommand configureFlags extraArgs++  where+    configureFlags   = filterConfigureFlags configFlags {+      configConfigurationsFlags = flags,+      configConstraints         = map thisPackageVersion deps,+      configVerbosity           = toFlag verbosity+    }++    pkg = case finalizePackageDescription flags+           (const True)+           platform comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc
+ Distribution/Client/Dependency.hs view
@@ -0,0 +1,441 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Top level interface to dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency (+    -- * The main package dependency resolver+    resolveDependencies,+    Progress(..),+    foldProgress,++    -- * Alternate, simple resolver that does not do dependencies recursively+    resolveWithoutDependencies,++    -- * Constructing resolver policies+    DepResolverParams(..),+    PackageConstraint(..),+    PackagesPreferenceDefault(..),+    PackagePreference(..),+    InstalledPreference(..),++    -- ** Standard policy+    standardInstallPolicy,+    PackageSpecifier(..),++    -- ** Extra policy options+    dontUpgradeBasePackage,+    hideBrokenInstalledPackages,+    upgradeDependencies,+    reinstallTargets,++    -- ** Policy utils+    addConstraints,+    addPreferences,+    setPreferenceDefault,+    addAvailablePackages,+    hideInstalledPackagesSpecific,+    hideInstalledPackagesAllVersions,+  ) where++import Distribution.Client.Dependency.TopDown (topDownResolver)+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Types+         ( AvailablePackageDb(AvailablePackageDb)+         , AvailablePackage(..), InstalledPackage )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)+         , Progress(..), foldProgress )+import Distribution.Client.Targets+import Distribution.Package+         ( PackageName(..), PackageId, Package(..), packageVersion+         , Dependency(Dependency))+import Distribution.Version+         ( VersionRange, anyVersion, withinRange, simplifyVersionRange )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils (comparing)+import Distribution.Text+         ( display )++import Data.List (maximumBy, foldl')+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+++-- ------------------------------------------------------------+-- * High level planner policy+-- ------------------------------------------------------------++-- | The set of parameters to the dependency resolver. These parameters are+-- relatively low level but many kinds of high level policies can be+-- implemented in terms of adjustments to the parameters.+--+data DepResolverParams = DepResolverParams {+       depResolverTargets           :: [PackageName],+       depResolverConstraints       :: [PackageConstraint],+       depResolverPreferences       :: [PackagePreference],+       depResolverPreferenceDefault :: PackagesPreferenceDefault,+       depResolverInstalled         :: PackageIndex InstalledPackage,+       depResolverAvailable         :: PackageIndex AvailablePackage+     }+++-- | Global policy for all packages to say if we prefer package versions that+-- are already installed locally or if we just prefer the latest available.+--+data PackagesPreferenceDefault =++     -- | Always prefer the latest version irrespective of any existing+     -- installed version.+     --+     -- * This is the standard policy for upgrade.+     --+     PreferAllLatest++     -- | Always prefer the installed versions over ones that would need to be+     -- installed. Secondarily, prefer latest versions (eg the latest installed+     -- version or if there are none then the latest available version).+   | PreferAllInstalled++     -- | Prefer the latest version for packages that are explicitly requested+     -- but prefers the installed version for any other packages.+     --+     -- * This is the standard policy for install.+     --+   | PreferLatestForSelected+++-- | A package selection preference for a particular package.+--+-- Preferences are soft constraints that the dependency resolver should try to+-- respect where possible. It is not specified if preferences on some packages+-- are more important than others.+--+data PackagePreference =++     -- | A suggested constraint on the version number.+     PackageVersionPreference   PackageName VersionRange++     -- | If we prefer versions of packages that are already installed.+   | PackageInstalledPreference PackageName InstalledPreference++basicDepResolverParams :: PackageIndex InstalledPackage+                       -> PackageIndex AvailablePackage+                       -> DepResolverParams+basicDepResolverParams installed available =+    DepResolverParams {+       depResolverTargets           = [],+       depResolverConstraints       = [],+       depResolverPreferences       = [],+       depResolverPreferenceDefault = PreferLatestForSelected,+       depResolverInstalled         = installed,+       depResolverAvailable         = available+     }++addTargets :: [PackageName]+           -> DepResolverParams -> DepResolverParams+addTargets extraTargets params =+    params {+      depResolverTargets = extraTargets ++ depResolverTargets params+    }++addConstraints :: [PackageConstraint]+               -> DepResolverParams -> DepResolverParams+addConstraints extraConstraints params =+    params {+      depResolverConstraints = extraConstraints+                            ++ depResolverConstraints params+    }++addPreferences :: [PackagePreference]+               -> DepResolverParams -> DepResolverParams+addPreferences extraPreferences params =+    params {+      depResolverPreferences = extraPreferences+                            ++ depResolverPreferences params+    }++setPreferenceDefault :: PackagesPreferenceDefault+                     -> DepResolverParams -> DepResolverParams+setPreferenceDefault preferenceDefault params =+    params {+      depResolverPreferenceDefault = preferenceDefault+    }++dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams+dontUpgradeBasePackage params =+    addConstraints extraConstraints params+  where+    extraConstraints =+      [ PackageInstalledConstraint pkgname+      | all (/=PackageName "base") (depResolverTargets params)+      , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]+      , isInstalled pkgname ]+    -- TODO: the top down resolver chokes on the base constraints+    -- below when there are no targets and thus no dep on base.+    -- Need to refactor contraints separate from needing packages.+    isInstalled = not . null+                . PackageIndex.lookupPackageName (depResolverInstalled params)++addAvailablePackages :: [AvailablePackage]+                     -> DepResolverParams -> DepResolverParams+addAvailablePackages pkgs params =+    params {+      depResolverAvailable = foldl (flip PackageIndex.insert)+                                   (depResolverAvailable params) pkgs+    }++hideInstalledPackagesSpecific :: [PackageId]+                              -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecific pkgids params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalled = foldl' (flip PackageIndex.deletePackageId)+                                    (depResolverInstalled params) pkgids+    }++hideInstalledPackagesAllVersions :: [PackageName]+                                 -> DepResolverParams -> DepResolverParams+hideInstalledPackagesAllVersions pkgnames params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalled =+        foldl' (flip PackageIndex.deletePackageName)+               (depResolverInstalled params) pkgnames+    }+++hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams+hideBrokenInstalledPackages params =+    hideInstalledPackagesSpecific pkgids params+  where+    pkgids = map packageId+           . PackageIndex.reverseDependencyClosure (depResolverInstalled params)+           . map (packageId . fst)+           . PackageIndex.brokenPackages+           $ depResolverInstalled params+++upgradeDependencies :: DepResolverParams -> DepResolverParams+upgradeDependencies = setPreferenceDefault PreferAllLatest+++reinstallTargets :: DepResolverParams -> DepResolverParams+reinstallTargets params =+    hideInstalledPackagesAllVersions (depResolverTargets params) params+++standardInstallPolicy :: PackageIndex InstalledPackage+                      -> AvailablePackageDb+                      -> [PackageSpecifier AvailablePackage]+                      -> DepResolverParams+standardInstallPolicy+    installed (AvailablePackageDb available availablePrefs) pkgSpecifiers++  = addPreferences+      [ PackageVersionPreference name ver+      | (name, ver) <- Map.toList availablePrefs ]++  . addConstraints+      (concatMap pkgSpecifierConstraints pkgSpecifiers)++  . addTargets+      (map pkgSpecifierTarget pkgSpecifiers)++  . hideInstalledPackagesSpecific+      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]++  . addAvailablePackages+      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]++  $ basicDepResolverParams+      installed available+++-- ------------------------------------------------------------+-- * Interface to the standard resolver+-- ------------------------------------------------------------++defaultResolver :: DependencyResolver+defaultResolver = topDownResolver++-- | Run the dependency solver.+--+-- Since this is potentially an expensive operation, the result is wrapped in a+-- a 'Progress' structure that can be unfolded to provide progress information,+-- logging messages and the final result or an error.+--+resolveDependencies :: Platform+                    -> CompilerId+                    -> DepResolverParams+                    -> Progress String String InstallPlan++    --TODO: is this needed here? see dontUpgradeBasePackage+resolveDependencies platform comp params+  | null (depResolverTargets params)+  = return (mkInstallPlan platform comp [])++resolveDependencies platform comp params =++    fmap (mkInstallPlan platform comp)+  $ defaultResolver platform comp installed available+                    preferences constraints targets+  where+    DepResolverParams+      targets constraints+      prefs defpref+      installed available = dontUpgradeBasePackage+                          . hideBrokenInstalledPackages+                          $ params++    preferences = interpretPackagesPreference+                    (Set.fromList targets) defpref prefs+++-- | Make an install plan from the output of the dep resolver.+-- It checks that the plan is valid, or it's an error in the dep resolver.+--+mkInstallPlan :: Platform+              -> CompilerId+              -> [InstallPlan.PlanPackage] -> InstallPlan+mkInstallPlan platform comp pkgs =+  case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of+    Right plan     -> plan+    Left  problems -> error $ unlines $+        "internal error: could not construct a valid install plan."+      : "The proposed (invalid) plan contained the following problems:"+      : map InstallPlan.showPlanProblem problems+++-- | Give an interpretation to the global 'PackagesPreference' as+--  specific per-package 'PackageVersionPreference'.+--+interpretPackagesPreference :: Set PackageName+                            -> PackagesPreferenceDefault+                            -> [PackagePreference]+                            -> (PackageName -> PackagePreferences)+interpretPackagesPreference selected defaultPref prefs =+  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)++  where+    versionPref pkgname =+      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageVersionPreference pkgname pref <- prefs ]++    installPref pkgname =+      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)+    installPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageInstalledPreference pkgname pref <- prefs ]+    installPrefDefault = case defaultPref of+      PreferAllLatest         -> \_       -> PreferLatest+      PreferAllInstalled      -> \_       -> PreferInstalled+      PreferLatestForSelected -> \pkgname ->+        -- When you say cabal install foo, what you really mean is, prefer the+        -- latest version of foo, but the installed version of everything else+        if pkgname `Set.member` selected then PreferLatest+                                         else PreferInstalled++-- ------------------------------------------------------------+-- * Simple resolver that ignores dependencies+-- ------------------------------------------------------------++-- | A simplistic method of resolving a list of target package names to+-- available packages.+--+-- Specifically, it does not consider package dependencies at all. Unlike+-- 'resolveDependencies', no attempt is made to ensure that the selected+-- packages have dependencies that are satisfiable or consistent with+-- each other.+--+-- It is suitable for tasks such as selecting packages to download for user+-- inspection. It is not suitable for selecting packages to install.+--+-- Note: if no installed package index is available, it is ok to pass 'mempty'.+-- It simply means preferences for installed packages will be ignored.+--+resolveWithoutDependencies :: DepResolverParams+                           -> Either [ResolveNoDepsError] [AvailablePackage]+resolveWithoutDependencies (DepResolverParams targets constraints+                                prefs defpref installed available) =+    collectEithers (map selectPackage targets)+  where+    selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage+    selectPackage pkgname+      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions+      | otherwise    = Right $! maximumBy bestByPrefs choices++      where+        -- Constraints+        requiredVersions = packageConstraints pkgname+        pkgDependency    = Dependency pkgname requiredVersions+        choices          = PackageIndex.lookupDependency available pkgDependency++        -- Preferences+        PackagePreferences preferredVersions preferInstalled+          = packagePreferences pkgname++        bestByPrefs   = comparing $ \pkg ->+                          (installPref pkg, versionPref pkg, packageVersion pkg)+        installPref   = case preferInstalled of+          PreferLatest    -> const False+          PreferInstalled -> isJust . PackageIndex.lookupPackageId installed+                           . packageId+        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions++    packageConstraints :: PackageName -> VersionRange+    packageConstraints pkgname =+      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap+    packageVersionConstraintMap =+      Map.fromList [ (name, range)+                   | PackageVersionConstraint name range <- constraints ]++    packagePreferences :: PackageName -> PackagePreferences+    packagePreferences = interpretPackagesPreference+                           (Set.fromList targets) defpref prefs+++collectEithers :: [Either a b] -> Either [a] [b]+collectEithers = collect . partitionEithers+  where+    collect ([], xs) = Right xs+    collect (errs,_) = Left errs+    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)++-- | Errors for 'resolveWithoutDependencies'.+--+data ResolveNoDepsError =++     -- | A package name which cannot be resolved to a specific package.+     -- Also gives the constraint on the version and whether there was+     -- a constraint on the package being installed.+     ResolveUnsatisfiable PackageName VersionRange++instance Show ResolveNoDepsError where+  show (ResolveUnsatisfiable name ver) =+       "There is no available version of " ++ display name+    ++ " that satisfies " ++ display (simplifyVersionRange ver)
+ Distribution/Client/Dependency/Modular.hs view
@@ -0,0 +1,58 @@+module Distribution.Client.Dependency.Modular+         ( modularResolver, SolverConfig(..)) where++-- Here, we try to map between the external cabal-install solver+-- interface and the internal interface that the solver actually+-- expects. There are a number of type conversions to perform: we+-- have to convert the package indices to the uniform index used+-- by the solver; we also have to convert the initial constraints;+-- and finally, we have to convert back the resulting install+-- plan.++import Data.Map as M+         ( fromListWith )+import Distribution.Client.Dependency.Modular.Assignment+         ( Assignment, toCPs )+import Distribution.Client.Dependency.Modular.Dependency+         ( RevDepMap )+import Distribution.Client.Dependency.Modular.ConfiguredConversion+         ( convCP )+import Distribution.Client.Dependency.Modular.IndexConversion+         ( convPIs )+import Distribution.Client.Dependency.Modular.Log+         ( logToProgress )+import Distribution.Client.Dependency.Modular.Package+         ( PN )+import Distribution.Client.Dependency.Modular.Solver+         ( SolverConfig(..), solve )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..) )+import Distribution.Client.InstallPlan+         ( PlanPackage )+import Distribution.System+         ( Platform(..) )++-- | Ties the two worlds together: classic cabal-install vs. the modular+-- solver. Performs the necessary translations before and after.+modularResolver :: SolverConfig -> DependencyResolver+modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =+  fmap (uncurry postprocess)      $ -- convert install plan+  logToProgress (maxBackjumps sc) $ -- convert log format into progress format+  solve sc idx pprefs gcs pns+    where+      -- Indices have to be converted into solver-specific uniform index.+      idx    = convPIs os arch cid (shadowPkgs sc) iidx sidx+      -- Constraints have to be converted into a finite map indexed by PN.+      gcs    = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)++      -- Results have to be converted into an install plan.+      postprocess :: Assignment -> RevDepMap -> [PlanPackage]+      postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)++      -- Helper function to extract the PN from a constraint.+      pcName :: PackageConstraint -> PN+      pcName (PackageConstraintVersion   pn _) = pn+      pcName (PackageConstraintInstalled pn  ) = pn+      pcName (PackageConstraintSource    pn  ) = pn+      pcName (PackageConstraintFlags     pn _) = pn+      pcName (PackageConstraintStanzas   pn _) = pn
+ Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -0,0 +1,146 @@+module Distribution.Client.Dependency.Modular.Assignment where++import Control.Applicative+import Control.Monad+import Data.Array as A+import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Graph+import Prelude hiding (pi)++import Distribution.PackageDescription (FlagAssignment) -- from Cabal+import Distribution.Client.Types (OptionalStanza)++import Distribution.Client.Dependency.Modular.Configured+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Version++-- | A (partial) package assignment. Qualified package names+-- are associated with instances.+type PAssignment    = Map QPN I++-- | A (partial) package preassignment. Qualified package names+-- are associated with constrained instances. Constrained instances+-- record constraints about the instances that can still be chosen,+-- and in the extreme case fix a concrete instance.+type PPreAssignment = Map QPN (CI QPN)+type FAssignment    = Map QFN Bool+type SAssignment    = Map QSN Bool++-- | A (partial) assignment of variables.+data Assignment = A PAssignment FAssignment SAssignment+  deriving (Show, Eq)++-- | A preassignment comprises knowledge about variables, but not+-- necessarily fixed values.+data PreAssignment = PA PPreAssignment FAssignment SAssignment++-- | Extend a package preassignment.+--+-- Either returns a witness of the conflict that would arise during the merge,+-- or the successfully extended assignment.+extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+extend var pa qa = foldM (\ a (Dep qpn ci) ->+                     let ci' = M.findWithDefault (Constrained []) qpn a+                     in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of+                           Left (c, (d, d')) -> Left  (c, L.map (Dep qpn) (simplify (P qpn) d d'))+                           Right x           -> Right x)+                    pa qa+  where+    -- We're trying to remove trivial elements of the conflict. If we're just+    -- making a choice pkg == instance, and pkg => pkg == instance is a part+    -- of the conflict, then this info is clear from the context and does not+    -- have to be repeated.+    simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]+    simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]+    simplify _ c                       d                           = [c, d]++-- | Delivers an ordered list of fully configured packages.+--+-- TODO: This function is (sort of) ok. However, there's an open bug+-- w.r.t. unqualification. There might be several different instances+-- of one package version chosen by the solver, which will lead to+-- clashes.+toCPs :: Assignment -> RevDepMap -> [CP QPN]+toCPs (A pa fa sa) rdm =+  let+    -- get hold of the graph+    g   :: Graph+    vm  :: Vertex -> ((), QPN, [QPN])+    cvm :: QPN -> Maybe Vertex+    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.+    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))+                                  (M.toList rdm))+    tg :: Graph+    tg = transposeG g+    -- Topsort the dependency graph, yielding a list of pkgs in the right order.+    -- The graph will still contain all the installed packages, and it might+    -- contain duplicates, because several variables might actually resolve to+    -- the same package in the presence of qualified package names.+    ps :: [PI QPN]+    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $+         topSort g+    -- Determine the flags per package, by walking over and regrouping the+    -- complete flag assignment by package.+    fapp :: Map QPN FlagAssignment+    fapp = M.fromListWith (++) $+           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $+           M.toList $+           fa+    -- Stanzas per package.+    sapp :: Map QPN [OptionalStanza]+    sapp = M.fromListWith (++) $+           L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $+           M.toList $+           sa+    -- Dependencies per package.+    depp :: QPN -> [PI QPN]+    depp qpn = let v :: Vertex+                   v   = fromJust (cvm qpn)+                   dvs :: [Vertex]+                   dvs = tg A.! v+               in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs+  in+    L.map (\ pi@(PI qpn _) -> CP pi+                                 (M.findWithDefault [] qpn fapp)+                                 (M.findWithDefault [] qpn sapp)+                                 (depp qpn))+          ps++-- | Finalize an assignment and a reverse dependency map.+--+-- This is preliminary, and geared towards output right now.+finalize :: Index -> Assignment -> RevDepMap -> IO ()+finalize idx (A pa fa _) rdm =+  let+    -- get hold of the graph+    g  :: Graph+    vm :: Vertex -> ((), QPN, [QPN])+    (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))+    -- topsort the dependency graph, yielding a list of pkgs in the right order+    f :: [PI QPN]+    f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g))+    fapp :: Map QPN [(QFN, Bool)] -- flags per package+    fapp = M.fromListWith (++) $+           L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa+    -- print one instance+    ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp)+    -- print install status+    status :: PI QPN -> String+    status (PI (Q _ pn) _) =+      case insts of+        [] -> " (new)"+        vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")"+      where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $+                    M.keys (M.findWithDefault M.empty pn idx)+            isInstalled (I _ (Inst _ )) = True+            isInstalled _               = False+    -- print flag assignment+    pflags = unwords . L.map (uncurry showFBool)+  in+    -- show packages with associated flag assignments+    putStr (unlines (L.map ppi f))
+ Distribution/Client/Dependency/Modular/Builder.hs view
@@ -0,0 +1,143 @@+module Distribution.Client.Dependency.Modular.Builder where++-- Building the search tree.+--+-- In this phase, we build a search tree that is too large, i.e, it contains+-- invalid solutions. We keep track of the open goals at each point. We+-- nondeterministically pick an open goal (via a goal choice node), create+-- subtrees according to the index and the available solutions, and extend the+-- set of open goals by superficially looking at the dependencies recorded in+-- the index.+--+-- For each goal, we keep track of all the *reasons* why it is being+-- introduced. These are for debugging and error messages, mainly. A little bit+-- of care has to be taken due to the way we treat flags. If a package has+-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we+-- store the entire dependency.++import Control.Monad.Reader hiding (sequence, mapM)+import Data.List as L+import Data.Map as M+import Prelude hiding (sequence, mapM)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- | The state needed during the build phase of the search tree.+data BuildState = BS {+  index :: Index,           -- ^ information about packages and their dependencies+  scope :: Scope,           -- ^ information about encapsulations+  rdeps :: RevDepMap,       -- ^ set of all package goals, completed and open, with reverse dependencies+  open  :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals)+  next  :: BuildType        -- ^ kind of node to generate next+}++-- | Extend the set of open goals with the new goals listed.+--+-- We also adjust the map of overall goals, and keep track of the+-- reverse dependencies of each of the goals.+extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs+  where+    go g o []                                             = s { rdeps = g, open = o }+    go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs+    go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs+    go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)+      | qpn == qpn'                                       = go                       g              o  ngs+                                       -- we ignore self-dependencies at this point; TODO: more care may be needed+      | qpn `M.member` g                                  = go (M.adjust (qpn':) qpn g)             o  ngs+      | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs+                                       -- code above is correct; insert/adjust have different arg order++-- | Update the current scope by taking into account the encapsulations that+-- are defined for the current package.+establishScope :: QPN -> Encaps -> BuildState -> BuildState+establishScope (Q pp pn) ecs s =+    s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }+  where+    pp' = pn : pp -- new path++-- | Given the current scope, qualify all the package names in the given set of+-- dependencies and then extend the set of open goals accordingly.+scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagDefaults ->+                    BuildState -> BuildState+scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s+  where+    sc     = scope s+    qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names+    qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs+    gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs)++data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons++build :: BuildState -> Tree (QGoalReasons, Scope)+build = ana go+  where+    go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState++    -- If we have a choice between many goals, we just record the choice in+    -- the tree. We select each open goal in turn, and before we descend, remove+    -- it from the queue of open goals.+    go bs@(BS { rdeps = rds, open = gs, next = Goals })+      | P.null gs = DoneF rds+      | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })+                                              (P.splits gs))++    -- If we have already picked a goal, then the choice depends on the kind+    -- of goal.+    --+    -- For a package, we look up the instances available in the global info,+    -- and then handle each instance in turn.+    go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =+      case M.lookup pn idx of+        Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)+        Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->+                                                           (i, bs { next = Instance qpn i info gr }))+                                                         (M.toList pis)))+          -- TODO: data structure conversion is rather ugly here++    -- For a flag, we create only two subtrees, and we create them in the order+    -- that is indicated by the flag default.+    --+    -- TODO: Should we include the flag default in the tree?+    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) =+      FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b+        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),+         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))+      where+        reorder True  = id+        reorder False = reverse+        trivial = L.null t && L.null f++    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =+      SChoiceF qsn (gr, sc) trivial (P.fromList+        [(False,                                                                        bs  { next = Goals }),+         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])+      where+        trivial = L.null t++    -- For a particular instance, we change the state: we update the scope,+    -- and furthermore we update the set of goals.+    --+    -- TODO: We could inline this above.+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =+      go ((establishScope qpn ecs+             (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))+             { next = Goals })++-- | Interface to the tree builder. Just takes an index and a list of package names,+-- and computes the initial state and then the tree from there.+buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope)+buildTree idx ind igs =+    build (BS idx sc+                  (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))+                  (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))+                  Goals)+  where+    sc | ind       = makeIndependent igs+       | otherwise = emptyScope+    qpns           = L.map (qualify sc) igs
+ Distribution/Client/Dependency/Modular/Configured.hs view
@@ -0,0 +1,10 @@+module Distribution.Client.Dependency.Modular.Configured where++import Distribution.PackageDescription (FlagAssignment) -- from Cabal+import Distribution.Client.Types (OptionalStanza)++import Distribution.Client.Dependency.Modular.Package++-- | A configured package is a package instance together with+-- a flag assignment and complete dependencies.+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn]
+ Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view
@@ -0,0 +1,40 @@+module Distribution.Client.Dependency.Modular.ConfiguredConversion where++import Data.Maybe+import Prelude hiding (pi)++import Distribution.Client.InstallPlan+import Distribution.Client.Types+import Distribution.Compiler+import qualified Distribution.Client.PackageIndex as CI+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.System++import Distribution.Client.Dependency.Modular.Configured+import Distribution.Client.Dependency.Modular.Package++mkPlan :: Platform -> CompilerId ->+          SI.PackageIndex -> CI.PackageIndex SourcePackage ->+          [CP QPN] -> Either [PlanProblem] InstallPlan+mkPlan plat comp iidx sidx cps =+  new plat comp (CI.fromList (map (convCP iidx sidx) cps))++convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage ->+          CP QPN -> PlanPackage+convCP iidx sidx (CP qpi fa es ds) =+  case convPI qpi of+    Left  pi -> PreExisting $ InstalledPackage+                  (fromJust $ SI.lookupInstalledPackageId iidx pi)+                  (map convPI' ds)+    Right pi -> Configured $ ConfiguredPackage+                  (fromJust $ CI.lookupPackageId sidx pi)+                  fa+                  es+                  (map convPI' ds)++convPI :: PI QPN -> Either InstalledPackageId PackageId+convPI (PI _ (I _ (Inst pi))) = Left pi+convPI qpi                    = Right $ convPI' qpi++convPI' :: PI QPN -> PackageId+convPI' (PI (Q _ pn) (I v _))  = PackageIdentifier pn v
+ Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -0,0 +1,194 @@+module Distribution.Client.Dependency.Modular.Dependency where++import Prelude hiding (pi)++import Data.List as L+import Data.Map as M+import Data.Set as S++import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Version++-- | The type of variables that play a role in the solver.+-- Note that the tree currently does not use this type directly,+-- and rather has separate tree nodes for the different types of+-- variables. This fits better with the fact that in most cases,+-- these have to be treated differently.+--+-- TODO: This isn't the ideal location to declare the type,+-- but we need them for constrained instances.+data Var qpn = P qpn | F (FN qpn) | S (SN qpn)+  deriving (Eq, Ord, Show)++showVar :: Var QPN -> String+showVar (P qpn) = showQPN qpn+showVar (F qfn) = showQFN qfn+showVar (S qsn) = showQSN qsn++instance Functor Var where+  fmap f (P n)  = P (f n)+  fmap f (F fn) = F (fmap f fn)+  fmap f (S sn) = S (fmap f sn)++type ConflictSet qpn = Set (Var qpn)++showCS :: ConflictSet QPN -> String+showCS = intercalate ", " . L.map showVar . S.toList++-- | Constrained instance. If the choice has already been made, this is+-- a fixed instance, and we record the package name for which the choice+-- is for convenience. Otherwise, it is a list of version ranges paired with+-- the goals / variables that introduced them.+data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]+  deriving (Eq, Show)++instance Functor CI where+  fmap f (Fixed i g)       = Fixed i (fmap f g)+  fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)++instance ResetGoal CI where+  resetGoal g (Fixed i _)       = Fixed i g+  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)++type VROrigin qpn = (VR, Goal qpn)++-- | Helper function to collapse a list of version ranges with origins into+-- a single, simplified, version range.+collapse :: [VROrigin qpn] -> VR+collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst++showCI :: CI QPN -> String+showCI (Fixed i _)      = "==" ++ showI i+showCI (Constrained vr) = showVR (collapse vr)++-- | Merge constrained instances. We currently adopt a lazy strategy for+-- merging, i.e., we only perform actual checking if one of the two choices+-- is fixed. If the merge fails, we return a conflict set indicating the+-- variables responsible for the failure, as well as the two conflicting+-- fragments.+--+-- Note that while there may be more than one conflicting pair of version+-- ranges, we only return the first we find.+--+-- TODO: Different pairs might have different conflict sets. We're+-- obviously interested to return a conflict that has a "better" conflict+-- set in the sense the it contains variables that allow us to backjump+-- further. We might apply some heuristics here, such as to change the+-- order in which we check the constraints.+merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)+merge c@(Fixed i g1)       d@(Fixed j g2)+  | i == j                                    = Right c+  | otherwise                                 = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))+merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...+  where+    go []              = Right c+    go (d@(vr, g2) : vrs)+      | checkVR vr v   = go vrs+      | otherwise      = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))+merge c@(Constrained _)    d@(Fixed _ _)      = merge d c+merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))+++type FlaggedDeps qpn = [FlaggedDep qpn]++-- | Flagged dependencies can either be plain dependency constraints,+-- or flag-dependent dependency trees.+data FlaggedDep qpn =+    Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+  | Stanza  (SN qpn)          (TrueFlaggedDeps qpn)+  | Simple (Dep qpn)+  deriving (Eq, Show)++instance Functor FlaggedDep where+  fmap f (Flagged x y tt ff) = Flagged (fmap f x) y+                                       (fmap (fmap f) tt) (fmap (fmap f) ff)+  fmap f (Stanza x tt)       = Stanza (fmap f x) (fmap (fmap f) tt)+  fmap f (Simple d)          = Simple (fmap f d)++type TrueFlaggedDeps  qpn = FlaggedDeps qpn+type FalseFlaggedDeps qpn = FlaggedDeps qpn++-- | A dependency (constraint) associates a package name with a+-- constrained instance.+data Dep qpn = Dep qpn (CI qpn)+  deriving (Eq, Show)++showDep :: Dep QPN -> String+showDep (Dep qpn (Fixed i (Goal v _))          ) =+  (if P qpn /= v then showVar v ++ " => " else "") +++  showQPN qpn ++ "==" ++ showI i+showDep (Dep qpn (Constrained [(vr, Goal v _)])) =+  showVar v ++ " => " ++ showQPN qpn ++ showVR vr+showDep (Dep qpn ci                            ) =+  showQPN qpn ++ showCI ci++instance Functor Dep where+  fmap f (Dep x y) = Dep (f x) (fmap f y)++instance ResetGoal Dep where+  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)++-- | A map containing reverse dependencies between qualified+-- package names.+type RevDepMap = Map QPN [QPN]++-- | Goals are solver variables paired with information about+-- why they have been introduced.+data Goal qpn = Goal (Var qpn) (GoalReasons qpn)+  deriving (Eq, Show)++instance Functor Goal where+  fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr)++class ResetGoal f where+  resetGoal :: Goal qpn -> f qpn -> f qpn++instance ResetGoal Goal where+  resetGoal = const++-- | For open goals as they occur during the build phase, we need to store+-- additional information about flags.+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons+  deriving (Eq, Show)++-- | Reasons why a goal can be added to a goal set.+data GoalReason qpn =+    UserGoal+  | PDependency (PI qpn)+  | FDependency (FN qpn) Bool+  | SDependency (SN qpn)+  deriving (Eq, Show)++instance Functor GoalReason where+  fmap _ UserGoal           = UserGoal+  fmap f (PDependency pi)   = PDependency (fmap f pi)+  fmap f (FDependency fn b) = FDependency (fmap f fn) b+  fmap f (SDependency sn)   = SDependency (fmap f sn)++-- | The first element is the immediate reason. The rest are the reasons+-- for the reasons ...+type GoalReasons qpn = [GoalReason qpn]++type QGoalReasons = GoalReasons QPN++goalReasonToVars :: GoalReason qpn -> ConflictSet qpn+goalReasonToVars UserGoal                 = S.empty+goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)+goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn)+goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)++goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn+goalReasonsToVars = S.unions . L.map goalReasonToVars++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal -> Goal QPN+close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr+close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr+close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr++-- | Compute a conflic set from a goal. The conflict set contains the+-- closure of goal reasons as well as the variable of the goal itself.+toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn+toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr)
+ Distribution/Client/Dependency/Modular/Explore.hs view
@@ -0,0 +1,148 @@+module Distribution.Client.Dependency.Modular.Explore where++import Control.Applicative as A+import Data.Foldable+import Data.List as L+import Data.Map as M+import Data.Set as S++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Log+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- | Backjumping.+--+-- A tree traversal that tries to propagate conflict sets+-- up the tree from the leaves, and thereby cut branches.+-- All the tricky things are done in the function 'combine'.+backjump :: Tree a -> Tree (Maybe (ConflictSet QPN))+backjump = snd . cata go+  where+    go (FailF c fr) = (Just c, Fail c fr)+    go (DoneF rdm ) = (Nothing, Done rdm)+    go (PChoiceF qpn _   ts) = (c, PChoice qpn c   (P.fromList ts'))+      where+        ~(c, ts') = combine (P qpn) (P.toList ts) S.empty+    go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts'))+      where+        ~(c, ts') = combine (F qfn) (P.toList ts) S.empty+    go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))+      where+        ~(c, ts') = combine (S qsn) (P.toList ts) S.empty+    go (GoalChoiceF      ts) = (c, GoalChoice      (P.fromList ts'))+      where+        ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts+        c          = case cs of []    -> Nothing+                                d : _ -> d++-- | The 'combine' function is at the heart of backjumping. It takes+-- the variable we're currently considering, and a list of children+-- annotated with their respective conflict sets, and an accumulator+-- for the result conflict set. It returns a combined conflict set+-- for the parent node, and a (potentially shortened) list of children+-- with the annotations removed.+--+-- It is *essential* that we produce the results as early as possible.+-- In particular, we have to produce the list of children prior to+-- traversing the entire list -- otherwise we lose the desired behaviour+-- of being able to traverse the tree from left to right incrementally.+--+-- We can shorten the list of children if we find an individual conflict+-- set that does not contain the current variable. In this case, we can+-- just lift the conflict set to the current level, because the current+-- level cannot possibly have contributed to this conflict, so no other+-- choice at the current level would avoid the conflict.+--+-- If any of the children might contain a successful solution+-- (indicated by Nothing), then Nothing will be the combined+-- conflict set. If all children contain conflict sets, we can+-- take the union as the combined conflict set.+combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] ->+           ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)])+combine _   []                      c = (Just c, [])+combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $+                                        case d of+                                          Just e | not (var `S.member` e) -> (Just e, [])+                                                 | otherwise              -> combine var xs (e `S.union` c)+                                          Nothing                         -> (Nothing, snd $ combine var xs S.empty)++-- | Naive backtracking exploration of the search tree. This will yield correct+-- assignments only once the tree itself is validated.+explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))+explore = cata go+  where+    go (FailF _ _)           _           = A.empty+    go (DoneF rdm)           a           = pure (a, rdm)+    go (PChoiceF qpn _   ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice+      ts+    go (FChoiceF qfn _ _ ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice+      ts+    go (SChoiceF qsn _ _ ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice+      ts+    go (GoalChoiceF      ts) a           =+      casePSQ ts A.empty                      -- empty goal choice is an internal error+        (\ _k v _xs -> v a)                   -- commit to the first goal choice++-- | Version of 'explore' that returns a 'Log'.+exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap))+exploreLog = cata go+  where+    go (FailF c fr)          _           = failWith (Failure c fr)+    go (DoneF rdm)           a           = succeedWith Success (a, rdm)+    go (PChoiceF qpn c   ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryP (PI qpn k)) $     -- log and ...+                    r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice+      ts+    go (FChoiceF qfn c _ ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryF qfn k) $          -- log and ...+                    r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice+      ts+    go (SChoiceF qsn c _ ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryS qsn k) $          -- log and ...+                    r (A pa fa (M.insert qsn k sa))) -- record the pkg choice+      ts+    go (GoalChoiceF      ts) a           =+      casePSQ ts+        (failWith (Failure S.empty EmptyGoalChoice))   -- empty goal choice is an internal error+        (\ k v _xs -> continueWith (Next (close k)) (v a))     -- commit to the first goal choice++-- | Add in information about pruned trees.+--+-- TODO: This isn't quite optimal, because we do not merely report the shape of the+-- tree, but rather make assumptions about where that shape originated from. It'd be+-- better if the pruning itself would leave information that we could pick up at this+-- point.+backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a+backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'!+                           Nothing -> A.empty+                           Just cs -> failWith (Failure cs Backjump)++-- | Interface.+exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap)+exploreTree t = explore t (A M.empty M.empty M.empty)++-- | Interface.+exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap)+exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty)
+ Distribution/Client/Dependency/Modular/Flag.hs view
@@ -0,0 +1,69 @@+module Distribution.Client.Dependency.Modular.Flag where++import Data.Map as M+import Prelude hiding (pi)++import Distribution.PackageDescription hiding (Flag) -- from Cabal++import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Types (OptionalStanza(..))++-- | Flag name. Consists of a package instance and the flag identifier itself.+data FN qpn = FN (PI qpn) Flag+  deriving (Eq, Ord, Show)++-- | Extract the package name from a flag name.+getPN :: FN qpn -> qpn+getPN (FN (PI qpn _) _) = qpn++instance Functor FN where+  fmap f (FN x y) = FN (fmap f x) y++-- | Flag identifier. Just a string.+type Flag = FlagName++unFlag :: Flag -> String+unFlag (FlagName fn) = fn++-- | Flag default. Just a bool.+type FDefault = Bool++-- | Flag defaults.+type FlagDefaults = Map Flag FDefault++-- | Qualified flag name.+type QFN = FN QPN++-- | Stanza name. Paired with a package name, much like a flag.+data SN qpn = SN (PI qpn) OptionalStanza+  deriving (Eq, Ord, Show)++instance Functor SN where+  fmap f (SN x y) = SN (fmap f x) y++-- | Qualified stanza name.+type QSN = SN QPN++unStanza :: OptionalStanza -> String+unStanza TestStanzas  = "test"+unStanza BenchStanzas = "bench"++showQFNBool :: QFN -> Bool -> String+showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b++showQSNBool :: QSN -> Bool -> String+showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b++showFBool :: FN qpn -> Bool -> String+showFBool (FN _ f) True  = "+" ++ unFlag f+showFBool (FN _ f) False = "-" ++ unFlag f++showSBool :: SN qpn -> Bool -> String+showSBool (SN _ s) True  = "*" ++ unStanza s+showSBool (SN _ s) False = "!" ++ unStanza s++showQFN :: QFN -> String+showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f++showQSN :: QSN -> String+showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
+ Distribution/Client/Dependency/Modular/Index.hs view
@@ -0,0 +1,33 @@+module Distribution.Client.Dependency.Modular.Index where++import Data.List as L+import Data.Map as M+import Prelude hiding (pi)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree++-- | An index contains information about package instances. This is a nested+-- dictionary. Package names are mapped to instances, which in turn is mapped+-- to info.+type Index = Map PN (Map I PInfo)++-- | Info associated with a package instance.+-- Currently, dependencies, flags, encapsulations and failure reasons.+-- Packages that have a failure reason recorded for them are disabled+-- globally, for reasons external to the solver. We currently use this+-- for shadowing which essentially is a GHC limitation, and for+-- installed packages that are broken.+data PInfo = PInfo (FlaggedDeps PN) FlagDefaults Encaps (Maybe FailReason)+  deriving (Show)++-- | Encapsulations. A list of package names.+type Encaps = [PN]++mkIndex :: [(PN, I, PInfo)] -> Index+mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))++groupMap :: Ord a => [(a, b)] -> Map a [b]+groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)
+ Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -0,0 +1,185 @@+module Distribution.Client.Dependency.Modular.IndexConversion where++import Data.List as L+import Data.Map as M+import Data.Maybe+import Prelude hiding (pi)++import qualified Distribution.Client.PackageIndex as CI+import Distribution.Client.Types+import Distribution.Compiler+import Distribution.InstalledPackageInfo as IPI+import Distribution.Package                          -- from Cabal+import Distribution.PackageDescription as PD         -- from Cabal+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.Simple.Utils (equating)+import Distribution.System++import Distribution.Client.Dependency.Modular.Dependency as D+import Distribution.Client.Dependency.Modular.Flag as F+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Modular.Version++-- | Convert both the installed package index and the source package+-- index into one uniform solver index.+--+-- We use 'allPackagesByName' for the installed package index because+-- that returns us several instances of the same package and version+-- in order of preference. This allows us in principle to "shadow"+-- packages if there are several installed packages of the same version.+-- There are currently some shortcomings in both GHC and Cabal in+-- resolving these situations. However, the right thing to do is to+-- fix the problem there, so for now, shadowing is only activated if+-- explicitly requested.+convPIs :: OS -> Arch -> CompilerId -> Bool ->+           SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index+convPIs os arch cid sip iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)++-- | Convert a Cabal installed package index to the simpler,+-- more uniform index format of the solver.+convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)]+convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx+  where+    -- group installed packages by version+    versioned = L.map (groupBy (equating packageVersion))+    -- apply shadowing whenever there are multple installed packages with+    -- the same version+    combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn,+                                 (g, p) <- zip (id : repeat shadow) pbv ]+    -- shadowing is recorded in the package info+    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))+    shadow x                                     = x++convIPI :: Bool -> SI.PackageIndex -> Index+convIPI sip = mkIndex . convIPI' sip++-- | Convert a single installed package into the solver-specific format.+convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP idx ipi =+  let ipid = installedPackageId ipi+      i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+      pn = pkgName (sourcePackageId ipi)+  in  case mapM (convIPId pn idx) (IPI.depends ipi) of+        Nothing  -> (pn, i, PInfo [] M.empty [] (Just Broken))+        Just fds -> (pn, i, PInfo fds M.empty [] Nothing)+-- TODO: Installed packages should also store their encapsulations!++-- | Convert dependencies specified by an installed package id into+-- flagged dependencies of the solver.+--+-- May return Nothing if the package can't be found in the index. That+-- indicates that the original package having this dependency is broken+-- and should be ignored.+convIPId :: PN -> SI.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)+convIPId pn' idx ipid =+  case SI.lookupInstalledPackageId idx ipid of+    Nothing  -> Nothing+    Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+                    pn = pkgName (sourcePackageId ipi)+                in  Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))))++-- | Convert a cabal-install source package index to the simpler,+-- more uniform index format of the solver.+convSPI' :: OS -> Arch -> CompilerId ->+            CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]+convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages++convSPI :: OS -> Arch -> CompilerId ->+           CI.PackageIndex SourcePackage -> Index+convSPI os arch cid = mkIndex . convSPI' os arch cid++-- | Convert a single source package into the solver-specific format.+convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)+convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) =+  let i = I pv InRepo+  in  (pn, i, convGPD os arch cid (PI pn i) gpd)++-- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'+-- from 'Distribution.PackageDescription.Configuration' here, because we+-- want to keep the condition tree, but simplify much of the test.++-- | Convert a generic package description to a solver-specific 'PInfo'.+--+-- TODO: We currently just take all dependencies from all specified library,+-- executable and test components. This does not quite seem fair.+convGPD :: OS -> Arch -> CompilerId ->+           PI PN -> GenericPackageDescription -> PInfo+convGPD os arch cid pi+        (GenericPackageDescription _ flags libs exes tests benchs) =+  let+    fds = flagDefaults flags+  in+    PInfo+      (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    +++       concatMap   (convCondTree os arch cid pi fds (const True)     . snd) exes    +++      (prefix (Stanza (SN pi TestStanzas))+        (concatMap (convCondTree os arch cid pi fds (const True)     . snd) tests)) +++      (prefix (Stanza (SN pi BenchStanzas))+        (concatMap (convCondTree os arch cid pi fds (const True)     . snd) benchs)))+      fds+      [] -- TODO: add encaps+      Nothing++prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn+prefix _ []  = []+prefix f fds = [f fds]++-- | Convert flag information.+flagDefaults :: [PD.Flag] -> FlagDefaults+flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b))++-- | Convert condition trees to flagged dependencies.+convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults ->+                (a -> Bool) -> -- how to detect if a branch is active+                CondTree ConfVar [Dependency] a -> FlaggedDeps PN+convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)+  | p info    = L.map (D.Simple . convDep pn) ds  -- unconditional dependencies+              ++ concatMap (convBranch os arch cid pi fds p) branches+  | otherwise = []++-- | Branch interpreter.+--+-- Here, we try to simplify one of Cabal's condition tree branches into the+-- solver's flagged dependency format, which is weaker. Condition trees can+-- contain complex logical expression composed from flag choices and special+-- flags (such as architecture, or compiler flavour). We try to evaluate the+-- special flags and subsequently simplify to a tree that only depends on+-- simple flag choices.+convBranch :: OS -> Arch -> CompilerId ->+              PI PN -> FlagDefaults ->+              (a -> Bool) -> -- how to detect if a branch is active+              (Condition ConfVar,+               CondTree ConfVar [Dependency] a,+               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN+convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') =+  go c' (          convCondTree os arch cid pi fds p   t')+        (maybe [] (convCondTree os arch cid pi fds p) mf')+  where+    go :: Condition ConfVar ->+          FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN+    go (Lit True)  t _ = t+    go (Lit False) _ f = f+    go (CNot c)    t f = go c f t+    go (CAnd c d)  t f = go c (go d t f) f+    go (COr  c d)  t f = go c t (go d t f)+    go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f]+    go (Var (OS os')) t f+      | os == os'      = t+      | otherwise      = f+    go (Var (Arch arch')) t f+      | arch == arch'  = t+      | otherwise      = f+    go (Var (Impl cf' cvr')) t f+      | cf == cf' && checkVR cvr' cv = t+      | otherwise      = f++-- | Convert a Cabal dependency to a solver-specific dependency.+convDep :: PN -> Dependency -> Dep PN+convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])++-- | Convert a Cabal package identifier to a solver-specific dependency.+convPI :: PN -> PackageIdentifier -> Dep PN+convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])])
+ Distribution/Client/Dependency/Modular/Log.hs view
@@ -0,0 +1,96 @@+module Distribution.Client.Dependency.Modular.Log where++import Control.Applicative+import Data.List as L+import Data.Set as S++import Distribution.Client.Dependency.Types -- from Cabal++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree (FailReason(..))++-- | The 'Log' datatype.+--+-- Represents the progress of a computation lazily.+--+-- Parameterized over the type of actual messages and the final result.+type Log m a = Progress m () a++runLog :: Log m a -> ([m], Maybe a)+runLog (Done x)       = ([], Just x)+runLog (Fail _)       = ([], Nothing)+runLog (Step m p)     = let+                          (ms, r) = runLog p+                        in+                          (m : ms, r)++-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.+-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the+-- limit is 'Just 0', backtracking is completely disabled.+logToProgress :: Maybe Int -> Log Message a -> Progress String String a+logToProgress mbj l = let+                        (ms, s) = runLog l+                        (es, e) = proc 0 ms -- catch first error (always)+                        (ns, t) = case mbj of+                                    Nothing -> (ms, Nothing)+                                    Just n  -> proc n ms+                        -- prefer first error over later error+                        r       = case t of+                                    Nothing -> case s of+                                                 Nothing -> e+                                                 Just _  -> Nothing+                                    Just _  -> e+                      in go es -- trace for first error+                            (showMessages (const True) True ns) -- shortened run+                            r s+  where+    proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))+    proc _ []                             = ([], Nothing)+    proc n (   Failure cs Backjump  : xs@(Leave : Failure cs' Backjump : _))+      | cs == cs'                         = proc n xs -- repeated backjumps count as one+    proc 0 (   Failure cs Backjump  : _ ) = ([], Just cs)+    proc n (x@(Failure _  Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)+    proc n (x                       : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc  n      xs)++    -- The order of arguments is important! In particular 's' must not be evaluated+    -- unless absolutely necessary. It contains the final result, and if we shortcut+    -- with an error due to backjumping, evaluating 's' would still require traversing+    -- the entire tree.+    go ms (x : xs) r         s        = Step x (go ms xs r s)+    go ms []       (Just cs) _        = Fail ("Could not resolve dependencies:\n" +++                                        unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))+    go _  []       _         (Just s) = Done s+    go _  []       _         _        = Fail ("Could not resolve dependencies.") -- should not happen++logToProgress' :: Log Message a -> Progress String String a+logToProgress' l = let+                    (ms, r) = runLog l+                    xs      = showMessages (const True) True ms+                  in go xs r+  where+    go [x]    Nothing  = Fail x+    go []     Nothing  = Fail ""+    go []     (Just r) = Done r+    go (x:xs) r        = Step x (go xs r)+++runLogIO :: Log Message a -> IO (Maybe a)+runLogIO x =+  do+    let (ms, r) = runLog x+    putStr (unlines $ showMessages (const True) True ms)+    return r++failWith :: m -> Log m a+failWith m = Step m (Fail ())++succeedWith :: m -> a -> Log m a+succeedWith m x = Step m (Done x)++continueWith :: m -> Log m a -> Log m a+continueWith = Step++tryWith :: Message -> Log Message a -> Log Message a+tryWith m x = Step m (Step Enter x) <|> failWith Leave
+ Distribution/Client/Dependency/Modular/Message.hs view
@@ -0,0 +1,97 @@+module Distribution.Client.Dependency.Modular.Message where++import qualified Data.List as L+import Prelude hiding (pi)++import Distribution.Text -- from Cabal++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree++data Message =+    Enter           -- ^ increase indentation level+  | Leave           -- ^ decrease indentation level+  | TryP (PI QPN)+  | TryF QFN Bool+  | TryS QSN Bool+  | Next (Goal QPN)+  | Success+  | Failure (ConflictSet QPN) FailReason++-- | Transforms the structured message type to actual messages (strings).+--+-- Takes an additional relevance predicate. The predicate gets a stack of goal+-- variables and can decide whether messages regarding these goals are relevant.+-- You can plug in 'const True' if you're interested in a full trace. If you+-- want a slice of the trace concerning a particular conflict set, then plug in+-- a predicate returning 'True' on the empty stack and if the head is in the+-- conflict set.+--+-- The second argument indicates if the level numbers should be shown. This is+-- recommended for any trace that involves backtracking, because only the level+-- numbers will allow to keep track of backjumps.+showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]+showMessages p sl = go [] 0+  where+    go :: [Var QPN] -> Int -> [Message] -> [String]+    go _ _ []                            = []+    -- complex patterns+    go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms+    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms)+    go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms+    -- standard display+    go v l (Enter                  : ms) = go v          (l+1) ms+    go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms+    go v l (TryP pi@(PI qpn _)     : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms)+    go v l (TryF qfn b             : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms)+    go v l (TryS qsn b             : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms)+    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)+    go v l (Next _                 : ms) = go v l ms -- ignore flag goals in the log+    go v l (Success                : ms) = (atLevel v l $ "done") (go v l ms)+    go v l (Failure c fr           : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms)++    -- special handler for many subsequent package rejections+    goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]+    goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms+    goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)++    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level+    atLevel v l x xs+      | sl && p v = let s = show l+                    in  ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs+      | p v       = x : xs+      | otherwise = xs++showGRs :: QGoalReasons -> String+showGRs (gr : _) = showGR gr+showGRs []       = ""++showGR :: GoalReason QPN -> String+showGR UserGoal            = " (user goal)"+showGR (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"+showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"+showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"++showFR :: ConflictSet QPN -> FailReason -> String+showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"+showFR _ (Conflicting ds)               = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"+showFR _ CannotInstall                  = " (only already installed instances can be used)"+showFR _ CannotReinstall                = " (avoiding to reinstall a package with same version but new dependencies)"+showFR _ Shadowed                       = " (shadowed by another installed package with same version)"+showFR _ Broken                         = " (package is broken)"+showFR _ (GlobalConstraintVersion vr)   = " (global constraint requires " ++ display vr ++ ")"+showFR _ GlobalConstraintInstalled      = " (global constraint requires installed instance)"+showFR _ GlobalConstraintSource         = " (global constraint requires source instance)"+showFR _ GlobalConstraintFlag           = " (global constraint requires opposite flag selection)"+showFR _ (BuildFailureNotInIndex pn)    = " (unknown package: " ++ display pn ++ ")"+showFR c Backjump                       = " (backjumping, conflict set: " ++ showCS c ++ ")"+-- The following are internal failures. They should not occur. In the+-- interest of not crashing unnecessarily, we still just print an error+-- message though.+showFR _ (MalformedFlagChoice qfn)      = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)    = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"+showFR _ EmptyGoalChoice                = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
+ Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -0,0 +1,102 @@+module Distribution.Client.Dependency.Modular.PSQ where++-- Priority search queues.+--+-- I am not yet sure what exactly is needed. But we need a datastructure with+-- key-based lookup that can be sorted. We're using a sequence right now with+-- (inefficiently implemented) lookup, because I think that queue-based+-- opertions and sorting turn out to be more efficiency-critical in practice.++import Control.Applicative+import Data.Foldable+import Data.Function+import Data.List as S hiding (foldr)+import Data.Traversable+import Prelude hiding (foldr)++newtype PSQ k v = PSQ [(k, v)]+  deriving (Eq, Show)++instance Functor (PSQ k) where+  fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)++instance Foldable (PSQ k) where+  foldr op e (PSQ xs) = foldr op e (fmap snd xs)++instance Traversable (PSQ k) where+  traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs++keys :: PSQ k v -> [k]+keys (PSQ xs) = fmap fst xs++lookup :: Eq k => k -> PSQ k v -> Maybe v+lookup k (PSQ xs) = S.lookup k xs++map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2+map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)++mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v+mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs)++mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b+mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)++mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b+mapWithKeyState p (PSQ xs) s0 =+  PSQ (foldr (\ (k, v) r s -> case p s k v of+                                (w, n) -> (k, w) : (r n))+             (const []) xs s0)++delete :: Eq k => k -> PSQ k a -> PSQ k a+delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs))++fromList :: [(k, a)] -> PSQ k a+fromList = PSQ++cons :: k -> a -> PSQ k a -> PSQ k a+cons k x (PSQ xs) = PSQ ((k, x) : xs)++snoc :: PSQ k a -> k -> a -> PSQ k a+snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])++casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r+casePSQ (PSQ xs) n c =+  case xs of+    []          -> n+    (k, v) : ys -> c k v (PSQ ys)++splits :: PSQ k a -> PSQ k (a, PSQ k a)+splits xs =+  casePSQ xs+    (PSQ [])+    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys)))++sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a+sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)++sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a+sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)++filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)++filter :: (a -> Bool) -> PSQ k a -> PSQ k a+filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)++length :: PSQ k a -> Int+length (PSQ xs) = S.length xs++-- | "Lazy length".+--+-- Only approximates the length, but doesn't force the list.+llength :: PSQ k a -> Int+llength (PSQ [])       = 0+llength (PSQ (_:[]))   = 1+llength (PSQ (_:_:[])) = 2+llength (PSQ _)        = 3++null :: PSQ k a -> Bool+null (PSQ xs) = S.null xs++toList :: PSQ k a -> [(k, a)]+toList (PSQ xs) = xs
+ Distribution/Client/Dependency/Modular/Package.hs view
@@ -0,0 +1,113 @@+module Distribution.Client.Dependency.Modular.Package+  (module Distribution.Client.Dependency.Modular.Package,+   module Distribution.Package) where++import Data.List as L+import Data.Map as M++import Distribution.Package -- from Cabal+import Distribution.Text    -- from Cabal++import Distribution.Client.Dependency.Modular.Version++-- | A package name.+type PN = PackageName++-- | Unpacking a package name.+unPN :: PN -> String+unPN (PackageName pn) = pn++-- | Package version. A package name plus a version number.+type PV = PackageId++-- | Qualified package version.+type QPV = Q PV++-- | Package id. Currently just a black-box string.+type PId = InstalledPackageId++-- | Location. Info about whether a package is installed or not, and where+-- exactly it is located. For installed packages, uniquely identifies the+-- package instance via its 'PId'.+--+-- TODO: More information is needed about the repo.+data Loc = Inst PId | InRepo+  deriving (Eq, Ord, Show)++-- | Instance. A version number and a location.+data I = I Ver Loc+  deriving (Eq, Ord, Show)++-- | String representation of an instance.+showI :: I -> String+showI (I v InRepo)   = showVer v+showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i+  where+    -- A hack to extract the beginning of the package ABI hash+    shortId = snip (splitAt 4) (++ "...") .+              snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+    snip p f xs = case p xs of+                    (ys, zs) -> (if L.null zs then id else f) ys++-- | Package instance. A package name and an instance.+data PI qpn = PI qpn I+  deriving (Eq, Ord, Show)++-- | String representation of a package instance.+showPI :: PI QPN -> String+showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i++-- | Checks if a package instance corresponds to an installed package.+instPI :: PI qpn -> Bool+instPI (PI _ (I _ (Inst _))) = True+instPI _                     = False++instI :: I -> Bool+instI (I _ (Inst _)) = True+instI _              = False++instance Functor PI where+  fmap f (PI x y) = PI (f x) y++-- | Package path. (Stored in "reverse" order.)+type PP = [PN]++-- | String representation of a package path.+showPP :: PP -> String+showPP = intercalate "." . L.map display . reverse+++-- | A qualified entity. Pairs a package path with the entity.+data Q a = Q PP a+  deriving (Eq, Ord, Show)++-- | Standard string representation of a qualified entity.+showQ :: (a -> String) -> (Q a -> String)+showQ showa (Q [] x) = showa x+showQ showa (Q pp x) = showPP pp ++ "." ++ showa x++-- | Qualified package name.+type QPN = Q PN++-- | String representation of a qualified package path.+showQPN :: QPN -> String+showQPN = showQ display++-- | The scope associates every package with a path. The convention is that packages+-- not in the data structure have an empty path associated with them.+type Scope = Map PN PP++-- | An empty scope structure, for initialization.+emptyScope :: Scope+emptyScope = M.empty++-- | Create artificial parents for each of the package names, making+-- them all independent.+makeIndependent :: [PN] -> Scope+makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)++qualify :: Scope -> PN -> QPN+qualify sc pn = Q (findWithDefault [] pn sc) pn++unQualify :: Q a -> a+unQualify (Q _ x) = x
+ Distribution/Client/Dependency/Modular/Preference.hs view
@@ -0,0 +1,258 @@+module Distribution.Client.Dependency.Modular.Preference where++-- Reordering or pruning the tree in order to prefer or make certain choices.++import qualified Data.List as L+import qualified Data.Map as M+import Data.Monoid+import Data.Ord++import Distribution.Client.Dependency.Types+  ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )+import Distribution.Client.Types+  ( OptionalStanza(..) )++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Modular.Version++-- | Generic abstraction for strategies that just rearrange the package order.+-- Only packages that match the given predicate are reordered.+packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a+packageOrderFor p cmp = trav go+  where+    go (PChoiceF v@(Q _ pn) r cs)+      | p pn                        = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)+      | otherwise                   = PChoiceF v r                               cs+    go x                            = x++-- | Ordering that treats preferred versions as greater than non-preferred+-- versions.+preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering+preferredVersionsOrdering vr v1 v2 =+  compare (checkVR vr v1) (checkVR vr v2)++-- | Traversal that tries to establish package preferences (not constraints).+-- Works by reordering choice nodes.+preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a+preferPackagePreferences pcs = packageOrderFor (const True) preference+  where+    preference pn i1@(I v1 _) i2@(I v2 _) =+      let PackagePreferences vr ipref = pcs pn+      in  preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically+          locationsOrdering ipref i1 i2++    -- Note that we always rank installed before uninstalled, and later+    -- versions before earlier, but we can change the priority of the+    -- two orderings.+    locationsOrdering PreferInstalled v1 v2 =+      preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2+    locationsOrdering PreferLatest v1 v2 =+      preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2++-- | Ordering that treats installed instances as greater than uninstalled ones.+preferInstalledOrdering :: I -> I -> Ordering+preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ+preferInstalledOrdering (I _ (Inst _)) _              = GT+preferInstalledOrdering _              (I _ (Inst _)) = LT+preferInstalledOrdering _              _              = EQ++-- | Compare instances by their version numbers.+preferLatestOrdering :: I -> I -> Ordering+preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2++-- | Helper function that tries to enforce a single package constraint on a+-- given instance for a P-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r+  | checkVR vr v  = r+  | otherwise     = Fail c (GlobalConstraintVersion vr)+processPackageConstraintP c i       (PackageConstraintInstalled _)  r+  | instI i       = r+  | otherwise     = Fail c GlobalConstraintInstalled+processPackageConstraintP c i       (PackageConstraintSource    _)  r+  | not (instI i) = r+  | otherwise     = Fail c GlobalConstraintSource+processPackageConstraintP _ _       _                               r = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =+  case L.lookup f fa of+    Nothing            -> r+    Just b | b == b'   -> r+           | otherwise -> Fail c GlobalConstraintFlag+processPackageConstraintF _ _ _  _                             r = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =+  if not b' && s `elem` ss then Fail c GlobalConstraintFlag+                           else r+processPackageConstraintS _ _ _  _                             r = r++-- | Traversal that tries to establish various kinds of user constraints. Works+-- by selectively disabling choices that have been ruled out by global user+-- constraints.+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons+enforcePackageConstraints pcs = trav go+  where+    go (PChoiceF qpn@(Q _ pn)               gr    ts) =+      let c = toConflictSet (Goal (P qpn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ i -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id+                           (M.findWithDefault [] pn pcs)+      in PChoiceF qpn gr    (P.mapWithKey g ts)+    go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) =+      let c = toConflictSet (Goal (F qfn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in FChoiceF qfn gr tr (P.mapWithKey g ts)+    go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =+      let c = toConflictSet (Goal (S qsn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in SChoiceF qsn gr tr (P.mapWithKey g ts)+    go x = x++-- | Prefer installed packages over non-installed packages, generally.+-- All installed packages or non-installed packages are treated as+-- equivalent.+preferInstalled :: Tree a -> Tree a+preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering)++-- | Prefer packages with higher version numbers over packages with+-- lower version numbers, for certain packages.+preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a+preferLatestFor p = packageOrderFor p (const preferLatestOrdering)++-- | Prefer packages with higher version numbers over packages with+-- lower version numbers, for all packages.+preferLatest :: Tree a -> Tree a+preferLatest = preferLatestFor (const True)++-- | Require installed packages.+requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+requireInstalled p = trav go+  where+    go (PChoiceF v@(Q _ pn) i@(gr, _) cs)+      | p pn      = PChoiceF v i (P.mapWithKey installed cs)+      | otherwise = PChoiceF v i                         cs+      where+        installed (I _ (Inst _)) x = x+        installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall+    go x          = x++-- | Avoid reinstalls.+--+-- This is a tricky strategy. If a package version is installed already and the+-- same version is available from a repo, the repo version will never be chosen.+-- This would result in a reinstall (either destructively, or potentially,+-- shadowing). The old instance won't be visible or even present anymore, but+-- other packages might have depended on it.+--+-- TODO: It would be better to actually check the reverse dependencies of installed+-- packages. If they're not depended on, then reinstalling should be fine. Even if+-- they are, perhaps this should just result in trying to reinstall those other+-- packages as well. However, doing this all neatly in one pass would require to+-- change the builder, or at least to change the goal set after building.+avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+avoidReinstalls p = trav go+  where+    go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)+      | p pn      = PChoiceF qpn i disableReinstalls+      | otherwise = PChoiceF qpn i cs+      where+        disableReinstalls =+          let installed = [ v | (I v (Inst _), _) <- toList cs ]+          in  P.mapWithKey (notReinstall installed) cs++        notReinstall vs (I v InRepo) _+          | v `elem` vs                = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall+        notReinstall _  _            x = x+    go x          = x++-- | Always choose the first goal in the list next, abandoning all+-- other choices.+--+-- This is unnecessary for the default search strategy, because+-- it descends only into the first goal choice anyway,+-- but may still make sense to just reduce the tree size a bit.+firstGoal :: Tree a -> Tree a+firstGoal = trav go+  where+    go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t)+    go x                = x+    -- Note that we keep empty choice nodes, because they mean success.++-- | Transformation that tries to make a decision on base as early as+-- possible. In nearly all cases, there's a single choice for the base+-- package. Also, fixing base early should lead to better error messages.+preferBaseGoalChoice :: Tree a -> Tree a+preferBaseGoalChoice = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)+    go x                = x++    preferBase :: OpenGoal -> OpenGoal -> Ordering+    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT+    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT+    preferBase _ _                                                           = EQ++-- | Transformation that sorts choice nodes so that+-- child nodes with a small branching degree are preferred. As a+-- special case, choices with 0 branches will be preferred (as they+-- are immediately considered inconsistent), and choices with 1+-- branch will also be preferred (as they don't involve choice).+preferEasyGoalChoices :: Tree a -> Tree a+preferEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)+    go x                = x++-- | Transformation that tries to avoid making inconsequential+-- flag choices early.+deferDefaultFlagChoices :: Tree a -> Tree a+deferDefaultFlagChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)+    go x                = x++    defer :: Tree a -> Tree a -> Ordering+    defer (FChoice _ _ True _) _ = GT+    defer _ (FChoice _ _ True _) = LT+    defer _ _                    = EQ++-- | Variant of 'preferEasyGoalChoices'.+--+-- Only approximates the number of choices in the branches. Less accurate,+-- more efficient.+lpreferEasyGoalChoices :: Tree a -> Tree a+lpreferEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs)+    go x                = x++-- | Variant of 'preferEasyGoalChoices'.+--+-- I first thought that using a paramorphism might be faster here,+-- but it doesn't seem to make any difference.+preferEasyGoalChoices' :: Tree a -> Tree a+preferEasyGoalChoices' = para (inn . go)+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))+    go x                = fmap fst x+
+ Distribution/Client/Dependency/Modular/Solver.hs view
@@ -0,0 +1,52 @@+module Distribution.Client.Dependency.Modular.Solver where++import Data.Map as M++import Distribution.Client.Dependency.Types++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Builder+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Explore+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Log+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import qualified Distribution.Client.Dependency.Modular.Preference as P+import Distribution.Client.Dependency.Modular.Validate++-- | Various options for the modular solver.+data SolverConfig = SolverConfig {+  preferEasyGoalChoices :: Bool,+  independentGoals      :: Bool,+  avoidReinstalls       :: Bool,+  shadowPkgs            :: Bool,+  maxBackjumps          :: Maybe Int+}++solve :: SolverConfig ->   -- solver parameters+         Index ->          -- all available packages as an index+         (PN -> PackagePreferences) -> -- preferences+         Map PN [PackageConstraint] -> -- global constraints+         [PN] ->                       -- global goals+         Log Message (Assignment, RevDepMap)+solve sc idx userPrefs userConstraints userGoals =+  explorePhase     $+  heuristicsPhase  $+  preferencesPhase $+  validationPhase  $+  prunePhase       $+  buildPhase+  where+    explorePhase     = exploreTreeLog . backjump+    heuristicsPhase  = if preferEasyGoalChoices sc+                         then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices+                         else P.preferBaseGoalChoice+    preferencesPhase = P.preferPackagePreferences userPrefs+    validationPhase  = P.enforcePackageConstraints userConstraints .+                       validateTree idx+    prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .+                       -- packages that can never be "upgraded":+                       P.requireInstalled (`elem` [PackageName "base",+                                                   PackageName "ghc-prim"])+    buildPhase       = buildTree idx (independentGoals sc) userGoals
+ Distribution/Client/Dependency/Modular/Tree.hs view
@@ -0,0 +1,146 @@+module Distribution.Client.Dependency.Modular.Tree where++import Control.Applicative+import Control.Monad hiding (mapM)+import Data.Foldable+import Data.Traversable+import Prelude hiding (foldr, mapM)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Version++-- | Type of the search tree. Inlining the choice nodes for now.+data Tree a =+    PChoice     QPN a      (PSQ I        (Tree a))+  | FChoice     QFN a Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial+  | SChoice     QSN a Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial+  | GoalChoice             (PSQ OpenGoal (Tree a)) -- PSQ should never be empty+  | Done        RevDepMap+  | Fail        (ConflictSet QPN) FailReason+  deriving (Eq, Show)+  -- Above, a choice is called trivial if it clearly does not matter. The+  -- special case of triviality we actually consider is if there are no new+  -- dependencies introduced by this node.++instance Functor Tree where+  fmap  f (PChoice qpn i   xs) = PChoice qpn (f i)   (fmap (fmap f) xs)+  fmap  f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs)+  fmap  f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)+  fmap  f (GoalChoice      xs) = GoalChoice          (fmap (fmap f) xs)+  fmap _f (Done    rdm       ) = Done    rdm+  fmap _f (Fail    cs fr     ) = Fail    cs fr++data FailReason = InconsistentInitialConstraints+                | Conflicting [Dep QPN]+                | CannotInstall+                | CannotReinstall+                | Shadowed+                | Broken+                | GlobalConstraintVersion VR+                | GlobalConstraintInstalled+                | GlobalConstraintSource+                | GlobalConstraintFlag+                | BuildFailureNotInIndex PN+                | MalformedFlagChoice QFN+                | MalformedStanzaChoice QSN+                | EmptyGoalChoice+                | Backjump+  deriving (Eq, Show)++-- | Functor for the tree type.+data TreeF a b =+    PChoiceF    QPN a      (PSQ I        b)+  | FChoiceF    QFN a Bool (PSQ Bool     b)+  | SChoiceF    QSN a Bool (PSQ Bool     b)+  | GoalChoiceF            (PSQ OpenGoal b)+  | DoneF       RevDepMap+  | FailF       (ConflictSet QPN) FailReason++out :: Tree a -> TreeF a (Tree a)+out (PChoice    p i   ts) = PChoiceF    p i   ts+out (FChoice    p i b ts) = FChoiceF    p i b ts+out (SChoice    p i b ts) = SChoiceF    p i b ts+out (GoalChoice       ts) = GoalChoiceF       ts+out (Done       x       ) = DoneF       x+out (Fail       c x     ) = FailF       c x++inn :: TreeF a (Tree a) -> Tree a+inn (PChoiceF    p i   ts) = PChoice    p i   ts+inn (FChoiceF    p i b ts) = FChoice    p i b ts+inn (SChoiceF    p i b ts) = SChoice    p i b ts+inn (GoalChoiceF       ts) = GoalChoice       ts+inn (DoneF       x       ) = Done       x+inn (FailF       c x     ) = Fail       c x++instance Functor (TreeF a) where+  fmap f (PChoiceF    p i   ts) = PChoiceF    p i   (fmap f ts)+  fmap f (FChoiceF    p i b ts) = FChoiceF    p i b (fmap f ts)+  fmap f (SChoiceF    p i b ts) = SChoiceF    p i b (fmap f ts)+  fmap f (GoalChoiceF       ts) = GoalChoiceF       (fmap f ts)+  fmap _ (DoneF       x       ) = DoneF       x+  fmap _ (FailF       c x     ) = FailF       c x++instance Foldable (TreeF a) where+  foldr op e (PChoiceF    _ _   ts) = foldr op e ts+  foldr op e (FChoiceF    _ _ _ ts) = foldr op e ts+  foldr op e (SChoiceF    _ _ _ ts) = foldr op e ts+  foldr op e (GoalChoiceF       ts) = foldr op e ts+  foldr _  e (DoneF       _       ) = e+  foldr _  e (FailF       _ _     ) = e++instance Traversable (TreeF a) where+  traverse f (PChoiceF    p i   ts) = PChoiceF    <$> pure p <*> pure i <*>            traverse f ts+  traverse f (FChoiceF    p i b ts) = FChoiceF    <$> pure p <*> pure i <*> pure b <*> traverse f ts+  traverse f (SChoiceF    p i b ts) = SChoiceF    <$> pure p <*> pure i <*> pure b <*> traverse f ts+  traverse f (GoalChoiceF       ts) = GoalChoiceF <$>                                  traverse f ts+  traverse _ (DoneF       x       ) = DoneF       <$> pure x+  traverse _ (FailF       c x     ) = FailF       <$> pure c <*> pure x++-- | Determines whether a tree is active, i.e., isn't a failure node.+active :: Tree a -> Bool+active (Fail _ _) = False+active _          = True++-- | Determines how many active choices are available in a node. Note that we+-- count goal choices as having one choice, always.+choices :: Tree a -> Int+choices (PChoice    _ _   ts) = P.length (P.filter active ts)+choices (FChoice    _ _ _ ts) = P.length (P.filter active ts)+choices (SChoice    _ _ _ ts) = P.length (P.filter active ts)+choices (GoalChoice       _ ) = 1+choices (Done       _       ) = 1+choices (Fail       _ _     ) = 0++-- | Variant of 'choices' that only approximates the number of choices,+-- using 'llength'.+lchoices :: Tree a -> Int+lchoices (PChoice    _ _   ts) = P.llength (P.filter active ts)+lchoices (FChoice    _ _ _ ts) = P.llength (P.filter active ts)+lchoices (SChoice    _ _ _ ts) = P.llength (P.filter active ts)+lchoices (GoalChoice       _ ) = 1+lchoices (Done       _       ) = 1+lchoices (Fail       _ _     ) = 0++-- | Catamorphism on trees.+cata :: (TreeF a b -> b) -> Tree a -> b+cata phi x = (phi . fmap (cata phi) . out) x++trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b+trav psi x = cata (inn . psi) x++-- | Paramorphism on trees.+para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b+para phi = phi . fmap (\ x -> (para phi x, x)) . out++cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b+cataM phi = phi <=< mapM (cataM phi) <=< return . out++-- | Anamorphism on trees.+ana :: (b -> TreeF a b) -> b -> Tree a+ana psi = inn . fmap (ana psi) . psi++anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a)+anaM psi = return . inn <=< mapM (anaM psi) <=< psi
+ Distribution/Client/Dependency/Modular/Validate.hs view
@@ -0,0 +1,232 @@+module Distribution.Client.Dependency.Modular.Validate where++-- Validation of the tree.+--+-- The task here is to make sure all constraints hold. After validation, any+-- assignment returned by exploration of the tree should be a complete valid+-- assignment, i.e., actually constitute a solution.++import Control.Applicative+import Control.Monad.Reader hiding (sequence)+import Data.List as L+import Data.Map as M+import Data.Traversable+import Prelude hiding (sequence)++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- In practice, most constraints are implication constraints (IF we have made+-- a number of choices, THEN we also have to ensure that). We call constraints+-- that for which the precondiditions are fulfilled ACTIVE. We maintain a set+-- of currently active constraints that we pass down the node.+--+-- We aim at detecting inconsistent states as early as possible.+--+-- Whenever we make a choice, there are two things that need to happen:+--+--   (1) We must check that the choice is consistent with the currently+--       active constraints.+--+--   (2) The choice increases the set of active constraints. For the new+--       active constraints, we must check that they are consistent with+--       the current state.+--+-- We can actually merge (1) and (2) by saying the the current choice is+-- a new active constraint, fixing the choice.+--+-- If a test fails, we have detected an inconsistent state. We can+-- disable the current subtree and do not have to traverse it any further.+--+-- We need a good way to represent the current state, i.e., the current+-- set of active constraints. Since the main situation where we have to+-- search in it is (1), it seems best to store the state by package: for+-- every package, we store which versions are still allowed. If for any+-- package, we have inconsistent active constraints, we can also stop.+-- This is a particular way to read task (2):+--+--   (2, weak) We only check if the new constraints are consistent with+--       the choices we've already made, and add them to the active set.+--+--   (2, strong) We check if the new constraints are consistent with the+--       choices we've already made, and the constraints we already have.+--+-- It currently seems as if we're implementing the weak variant. However,+-- when used together with 'preferEasyGoalChoices', we will find an+-- inconsistent state in the very next step.+--+-- What do we do about flags?+--+-- Like for packages, we store the flag choices we have already made.+-- Now, regarding (1), we only have to test whether we've decided the+-- current flag before. Regarding (2), the interesting bit is in discovering+-- the new active constraints. To this end, we look up the constraints for+-- the package the flag belongs to, and traverse its flagged dependencies.+-- Wherever we find the flag in question, we start recording dependencies+-- underneath as new active dependencies. If we encounter other flags, we+-- check if we've chosen them already and either proceed or stop.++-- | The state needed during validation.+data ValidateState = VS {+  index :: Index,+  saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment+}++type Validate = Reader ValidateState++validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons)+validate = cata go+  where+    go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)++    go (PChoiceF qpn (gr,  sc)   ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)+    go (FChoiceF qfn (gr, _sc) b ts) =+      do+        -- Flag choices may occur repeatedly (because they can introduce new constraints+        -- in various places). However, subsequent choices must be consistent. We thereby+        -- collapse repeated flag choice nodes.+        PA _ pfa _ <- asks pa -- obtain current flag-preassignment+        case M.lookup qfn pfa of+          Just rb -> -- flag has already been assigned; collapse choice to the correct branch+                     case P.lookup rb ts of+                       Just t  -> goF qfn gr rb t+                       Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)+          Nothing -> -- flag choice is new, follow both branches+                     FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts)+    go (SChoiceF qsn (gr, _sc) b ts) =+      do+        -- Optional stanza choices are very similar to flag choices.+        PA _ _ psa <- asks pa -- obtain current stanza-preassignment+        case M.lookup qsn psa of+          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch+                     case P.lookup rb ts of+                       Just t  -> goS qsn gr rb t+                       Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)+          Nothing -> -- stanza choice is new, follow both branches+                     SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts)++    -- We don't need to do anything for goal choices or failure nodes.+    go (GoalChoiceF              ts) = GoalChoice <$> sequence ts+    go (DoneF    rdm               ) = pure (Done rdm)+    go (FailF    c fr              ) = pure (Fail c fr)++    -- What to do for package nodes ...+    goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goP qpn@(Q _pp pn) gr sc i r = do+      PA ppa pfa psa <- asks pa    -- obtain current preassignment+      idx            <- asks index -- obtain the index+      svd            <- asks saved -- obtain saved dependencies+      let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice+      let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope+      -- the new active constraints are given by the instance we have chosen,+      -- plus the dependency information we have for that instance+      let goal = Goal (P qpn) gr+      let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)+      -- We now try to extend the partial assignment with the new active constraints.+      let mnppa = extend (P qpn) ppa newactives+      -- In case we continue, we save the scoped dependencies+      let nsvd = M.insert qpn qdeps svd+      case mfr of+        Just fr -> -- The index marks this as an invalid choice. We can stop.+                   return (Fail (toConflictSet goal) fr)+        _       -> case mnppa of+                     Left (c, d) -> -- We have an inconsistency. We can stop.+                                    return (Fail c (Conflicting d))+                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.+                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r++    -- What to do for flag nodes ...+    goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goF qfn@(FN (PI qpn _i) _f) gr b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      svd <- asks saved         -- obtain saved dependencies+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npfa = M.insert qfn b pfa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend (F qfn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r++    -- What to do for stanza nodes (similar to flag nodes) ...+    goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goS qsn@(SN (PI qpn _i) _f) gr b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      svd <- asks saved         -- obtain saved dependencies+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npsa = M.insert qsn b psa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend (S qsn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r++-- | We try to extract as many concrete dependencies from the given flagged+-- dependencies as possible. We make use of all the flag knowledge we have+-- already acquired.+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]+extractDeps fa sa deps = do+  d <- deps+  case d of+    Simple sd           -> return sd+    Flagged qfn _ td fd -> case M.lookup qfn fa of+                             Nothing    -> mzero+                             Just True  -> extractDeps fa sa td+                             Just False -> extractDeps fa sa fd+    Stanza qsn td       -> case M.lookup qsn sa of+                             Nothing    -> mzero+                             Just True  -> extractDeps fa sa td+                             Just False -> []++-- | We try to find new dependencies that become available due to the given+-- flag or stanza choice. We therefore look for the choice in question, and then call+-- 'extractDeps' for everything underneath.+extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]+extractNewDeps v gr b fa sa = go+  where+    go deps = do+      d <- deps+      case d of+        Simple _             -> mzero+        Flagged qfn' _ td fd+          | v == F qfn'      -> L.map (resetGoal (Goal v gr)) $+                                if b then extractDeps fa sa td else extractDeps fa sa fd+          | otherwise        -> case M.lookup qfn' fa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> go fd+        Stanza qsn' td+          | v == S qsn'      -> L.map (resetGoal (Goal v gr)) $+                                if b then extractDeps fa sa td else []+          | otherwise        -> case M.lookup qsn' sa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> []++-- | Interface.+validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons+validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
+ Distribution/Client/Dependency/Modular/Version.hs view
@@ -0,0 +1,43 @@+module Distribution.Client.Dependency.Modular.Version where++import qualified Distribution.Version as CV -- from Cabal+import Distribution.Text -- from Cabal++-- | Preliminary type for versions.+type Ver = CV.Version++-- | String representation of a version.+showVer :: Ver -> String+showVer = display++-- | Version range. Consists of a lower and upper bound.+type VR = CV.VersionRange++-- | String representation of a version range.+showVR :: VR -> String+showVR = display++-- | Unconstrained version range.+anyVR :: VR+anyVR = CV.anyVersion++-- | Version range fixing a single version.+eqVR :: Ver -> VR+eqVR = CV.thisVersion++-- | Intersect two version ranges.+(.&&.) :: VR -> VR -> VR+(.&&.) = CV.intersectVersionRanges++-- | Simplify a version range.+simplifyVR :: VR -> VR+simplifyVR = CV.simplifyVersionRange++-- | Checking a version against a version range.+checkVR :: VR -> Ver -> Bool+checkVR = flip CV.withinRange++-- | Make a version number.+mkV :: [Int] -> Ver+mkV xs = CV.Version xs []+
+ Distribution/Client/Dependency/TopDown.hs view
@@ -0,0 +1,776 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown (+    topDownResolver+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints+import Distribution.Client.Dependency.TopDown.Constraints+         ( Satisfiable(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( PlanPackage(..) )+import Distribution.Client.Types+         ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)+         , Progress(..), foldProgress )++import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Package+         ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion+         , PackageFixedDeps(depends) )+import Distribution.PackageDescription+         ( PackageDescription(buildDepends) )+import Distribution.Client.PackageUtils+         ( externalBuildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription, flattenPackageDescription )+import Distribution.Version+         ( VersionRange, anyVersion, withinRange, simplifyVersionRange+         , UpperBound(..), asVersionIntervals )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils+         ( equating, comparing )+import Distribution.Text+         ( display )++import Data.List+         ( foldl', maximumBy, minimumBy, nub, sort, groupBy )+import Data.Maybe+         ( fromJust, fromMaybe, catMaybes )+import Data.Monoid+         ( Monoid(mempty) )+import Control.Monad+         ( guard )+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Control.Exception+         ( assert )++-- ------------------------------------------------------------+-- * Search state types+-- ------------------------------------------------------------++type Constraints  = Constraints.Constraints+                      InstalledPackageEx UnconfiguredPackage ExclusionReason+type SelectedPackages = PackageIndex SelectedPackage++-- ------------------------------------------------------------+-- * The search tree type+-- ------------------------------------------------------------++data SearchSpace inherited pkg+   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]+   | Failure Failure++-- ------------------------------------------------------------+-- * Traverse a search tree+-- ------------------------------------------------------------++explore :: (PackageName -> PackagePreferences)+        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)+                       SelectablePackage+        -> Progress Log Failure (SelectedPackages, Constraints)++explore _    (Failure failure)       = Fail failure+explore _    (ChoiceNode (s,c,_) []) = Done (s,c)+explore pref (ChoiceNode _ choices)  =+  case [ choice | [choice] <- choices ] of+    ((_, node'):_) -> Step (logInfo node') (explore pref node')+    []             -> Step (logInfo node') (explore pref node')+      where+        choice     = minimumBy (comparing topSortNumber) choices+        pkgname    = packageName . fst . head $ choice+        (_, node') = maximumBy (bestByPref pkgname) choice+  where+    topSortNumber choice = case fst (head choice) of+      InstalledOnly           (InstalledPackageEx  _ i _) -> i+      AvailableOnly           (UnconfiguredPackage _ i _) -> i+      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i++    bestByPref pkgname = case packageInstalledPreference of+        PreferLatest    ->+          comparing (\(p,_) -> (               isPreferred p, packageId p))+        PreferInstalled ->+          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))+      where+        isInstalled (AvailableOnly _) = False+        isInstalled _                 = True+        isPreferred p = packageVersion p `withinRange` preferredVersions+        (PackagePreferences preferredVersions packageInstalledPreference)+          = pref pkgname++    logInfo node = Select selected discarded+      where (selected, discarded) = case node of+              Failure    _               -> ([], [])+              ChoiceNode (_,_,changes) _ -> changes++-- ------------------------------------------------------------+-- * Generate a search tree+-- ------------------------------------------------------------++type ConfigurePackage = PackageIndex SelectablePackage+                     -> SelectablePackage+                     -> Either [Dependency] SelectedPackage++-- | (packages selected, packages discarded)+type SelectionChanges = ([SelectedPackage], [PackageIdentifier])++searchSpace :: ConfigurePackage+            -> Constraints+            -> SelectedPackages+            -> SelectionChanges+            -> Set PackageName+            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)+                           SelectablePackage+searchSpace configure constraints selected changes next =+  ChoiceNode (selected, constraints, changes)+    [ [ (pkg, select name pkg)+      | pkg <- PackageIndex.lookupPackageName available name ]+    | name <- Set.elems next ]+  where+    available = Constraints.choices constraints++    select name pkg = case configure available pkg of+      Left missing -> Failure $ ConfigureFailed pkg+                        [ (dep, Constraints.conflicting constraints dep)+                        | dep <- missing ]+      Right pkg' -> case constrainDeps pkg' newDeps constraints [] of+        Left failure       -> Failure failure+        Right (constraints', newDiscarded) ->+          searchSpace configure+            constraints' selected' (newSelected, newDiscarded) next'+        where+          selected' = foldl' (flip PackageIndex.insert) selected newSelected+          newSelected =+            case Constraints.isPaired constraints (packageId pkg) of+              Nothing     -> [pkg']+              Just pkgid' -> [pkg', pkg'']+                where+                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)+                    (PackageIndex.lookupPackageId available pkgid')++          newPkgs   = [ name'+                      | dep <- newDeps+                      , let (Dependency name' _) = untagDependency dep+                      , null (PackageIndex.lookupPackageName selected' name') ]+          newDeps   = concatMap packageConstraints newSelected+          next'     = Set.delete name+                    $ foldl' (flip Set.insert) next newPkgs++packageConstraints :: SelectedPackage -> [TaggedDependency]+packageConstraints = either installedConstraints availableConstraints+                   . preferAvailable+  where+    preferAvailable (InstalledOnly           pkg) = Left pkg+    preferAvailable (AvailableOnly           pkg) = Right pkg+    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg+    installedConstraints (InstalledPackageEx    _ _ deps) =+      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)+      | dep <- deps ]+    availableConstraints (SemiConfiguredPackage _ _ deps) =+      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]++constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints+              -> [PackageIdentifier]+              -> Either Failure (Constraints, [PackageIdentifier])+constrainDeps pkg []         cs discard =+  case addPackageSelectConstraint (packageId pkg) cs of+    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)+    _                        -> impossible+constrainDeps pkg (dep:deps) cs discard =+  case addPackageDependencyConstraint (packageId pkg) dep cs of+    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)+    Unsatisfiable            -> impossible+    ConflictsWith conflicts  ->+      Left (DependencyConflict pkg dep conflicts)++-- ------------------------------------------------------------+-- * The main algorithm+-- ------------------------------------------------------------++search :: ConfigurePackage+       -> (PackageName -> PackagePreferences)+       -> Constraints+       -> Set PackageName+       -> Progress Log Failure (SelectedPackages, Constraints)+search configure pref constraints =+  explore pref . searchSpace configure constraints mempty ([], [])++-- ------------------------------------------------------------+-- * The top level resolver+-- ------------------------------------------------------------++-- | The main exported resolver, with string logging and failure types to fit+-- the standard 'DependencyResolver' interface.+--+topDownResolver :: DependencyResolver+topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'+  where+    mapMessages :: Progress Log Failure a -> Progress String String a+    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done++-- | The native resolver with detailed structured logging and failure types.+--+topDownResolver' :: Platform -> CompilerId+                 -> PackageIndex InstalledPackage+                 -> PackageIndex AvailablePackage+                 -> (PackageName -> PackagePreferences)+                 -> [PackageConstraint]+                 -> [PackageName]+                 -> Progress Log Failure [PlanPackage]+topDownResolver' platform comp installed available+                 preferences constraints targets =+      fmap (uncurry finalise)+    . (\cs -> search configure preferences cs initialPkgNames)+  =<< addTopLevelConstraints constraints constraintSet++  where+    configure   = configurePackage platform comp+    constraintSet :: Constraints+    constraintSet = Constraints.empty+      (annotateInstalledPackages             topSortNumber installed')+      (annotateAvailablePackages constraints topSortNumber available')+    (installed', available') = selectNeededSubset installed available+                                                  initialPkgNames+    topSortNumber = topologicalSortNumbering installed' available'++    initialPkgNames = Set.fromList targets++    finalise selected' constraints' =+        PackageIndex.allPackages+      . fst . improvePlan installed' constraints'+      . PackageIndex.fromList+      $ finaliseSelectedPackages preferences selected' constraints'++addTopLevelConstraints :: [PackageConstraint] -> Constraints+                       -> Progress a Failure Constraints+addTopLevelConstraints []                                      cs = Done cs+addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =+  addTopLevelConstraints deps cs++addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =+  case addTopLevelVersionConstraint pkg ver cs of+    Satisfiable cs' _       ->+      addTopLevelConstraints deps cs'++    Unsatisfiable           ->+      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)++    ConflictsWith conflicts ->+      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)++addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =+  case addTopLevelInstalledConstraint pkg cs of+    Satisfiable cs' _       -> addTopLevelConstraints deps cs'++    Unsatisfiable           ->+      Fail (TopLevelInstallConstraintUnsatisfiable pkg)++    ConflictsWith conflicts ->+      Fail (TopLevelInstallConstraintConflict pkg conflicts)++configurePackage :: Platform -> CompilerId -> ConfigurePackage+configurePackage platform comp available spkg = case spkg of+  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)+  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)+  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)+                                          (configure apkg)+  where+  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =+    case finalizePackageDescription flags dependencySatisfiable+                                    platform comp [] p of+      Left missing        -> Left missing+      Right (pkg, flags') -> Right $+        SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)++  dependencySatisfiable = not . null . PackageIndex.lookupDependency available++-- | Annotate each installed packages with its set of transative dependencies+-- and its topological sort number.+--+annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)+                          -> PackageIndex InstalledPackage+                          -> PackageIndex InstalledPackageEx+annotateInstalledPackages dfsNumber installed = PackageIndex.fromList+  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)+  | pkg <- PackageIndex.allPackages installed ]+  where+    transitiveDepends :: InstalledPackage -> [PackageIdentifier]+    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph+                      . fromJust . toVertex . packageId+    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed+++-- | Annotate each available packages with its topological sort number and any+-- user-supplied partial flag assignment.+--+annotateAvailablePackages :: [PackageConstraint]+                          -> (PackageName -> TopologicalSortNumber)+                          -> PackageIndex AvailablePackage+                          -> PackageIndex UnconfiguredPackage+annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList+  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)+  | pkg <- PackageIndex.allPackages available+  , let name = packageName pkg ]+  where+    flagsFor = fromMaybe [] . flip Map.lookup flagsMap+    flagsMap = Map.fromList+      [ (name, flags)+      | PackageFlagsConstraint name flags <- constraints ]++-- | One of the heuristics we use when guessing which path to take in the+-- search space is an ordering on the choices we make. It's generally better+-- to make decisions about packages higer in the dep graph first since they+-- place constraints on packages lower in the dep graph.+--+-- To pick them in that order we annotate each package with its topological+-- sort number. So if package A depends on package B then package A will have+-- a lower topological sort number than B and we'll make a choice about which+-- version of A to pick before we make a choice about B (unless there is only+-- one possible choice for B in which case we pick that immediately).+--+-- To construct these topological sort numbers we combine and flatten the+-- installed and available package sets. We consider only dependencies between+-- named packages, not including versions and for not-yet-configured packages+-- we look at all the possible dependencies, not just those under any single+-- flag assignment. This means we can actually get impossible combinations of+-- edges and even cycles, but that doesn't really matter here, it's only a+-- heuristic.+--+topologicalSortNumbering :: PackageIndex InstalledPackage+                         -> PackageIndex AvailablePackage+                         -> (PackageName -> TopologicalSortNumber)+topologicalSortNumbering installed available =+    \pkgname -> let Just vertex = toVertex pkgname+                 in topologicalSortNumbers Array.! vertex+  where+    topologicalSortNumbers = Array.array (Array.bounds graph)+                                         (zip (Graph.topSort graph) [0..])+    (graph, _, toVertex)   = Graph.graphFromEdges $+         [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed+         , let deps = [ packageName dep+                      | pkg' <- pkgs+                      , dep  <- depends pkg' ] ]+      ++ [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available+         , let deps = [ depName+                      | AvailablePackage _ pkg' _ <- pkgs+                      , Dependency depName _ <-+                          buildDepends (flattenPackageDescription pkg') ] ]++-- | We don't need the entire index (which is rather large and costly if we+-- force it by examining the whole thing). So trace out the maximul subset of+-- each index that we could possibly ever need. Do this by flattening packages+-- and looking at the names of all possible dependencies.+--+selectNeededSubset :: PackageIndex InstalledPackage+                   -> PackageIndex AvailablePackage+                   -> Set PackageName+                   -> (PackageIndex InstalledPackage+                      ,PackageIndex AvailablePackage)+selectNeededSubset installed available = select mempty mempty+  where+    select :: PackageIndex InstalledPackage+           -> PackageIndex AvailablePackage+           -> Set PackageName+           -> (PackageIndex InstalledPackage+              ,PackageIndex AvailablePackage)+    select installed' available' remaining+      | Set.null remaining = (installed', available')+      | otherwise = select installed'' available'' remaining''+      where+        (next, remaining') = Set.deleteFindMin remaining+        moreInstalled = PackageIndex.lookupPackageName installed next+        moreAvailable = PackageIndex.lookupPackageName available next+        moreRemaining = -- we filter out packages already included in the indexes+                        -- this avoids an infinite loop if a package depends on itself+                        -- like base-3.0.3.0 with base-4.0.0.0+                        filter notAlreadyIncluded+                      $ [ packageName dep+                        | pkg <- moreInstalled+                        , dep <- depends pkg ]+                     ++ [ name+                        | AvailablePackage _ pkg _ <- moreAvailable+                        , Dependency name _ <-+                            buildDepends (flattenPackageDescription pkg) ]+        installed''   = foldl' (flip PackageIndex.insert) installed' moreInstalled+        available''   = foldl' (flip PackageIndex.insert) available' moreAvailable+        remaining''   = foldl' (flip         Set.insert) remaining' moreRemaining+        notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)+                                  && null (PackageIndex.lookupPackageName available' name)++-- ------------------------------------------------------------+-- * Post processing the solution+-- ------------------------------------------------------------++finaliseSelectedPackages :: (PackageName -> PackagePreferences)+                         -> SelectedPackages+                         -> Constraints+                         -> [PlanPackage]+finaliseSelectedPackages pref selected constraints =+  map finaliseSelected (PackageIndex.allPackages selected)+  where+    remainingChoices = Constraints.choices constraints+    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg+    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable Nothing apkg+    finaliseSelected (InstalledAndAvailable ipkg apkg) =+      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of+        Nothing                          -> impossible --picked package not in constraints+        Just (AvailableOnly _)           -> impossible --to constrain to avail only+        Just (InstalledOnly _)           -> finaliseInstalled ipkg+        Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg++    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg+    finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =+      InstallPlan.Configured (ConfiguredPackage pkg flags deps')+      where+        deps' = map (packageId . pickRemaining mipkg) deps++    pickRemaining mipkg dep@(Dependency _name versionRange) =+          case PackageIndex.lookupDependency remainingChoices dep of+            []        -> impossible+            [pkg']    -> pkg'+            remaining -> assert (checkIsPaired remaining)+                       $ maximumBy bestByPref remaining+      where+        -- We order candidate packages to pick for a dependency by these+        -- three factors. The last factor is just highest version wins.+        bestByPref =+          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))+        -- Is the package already used by the installed version of this+        -- package? If so we should pick that first. This stops us from doing+        -- silly things like deciding to rebuild haskell98 against base 3.+        isCurrent = case mipkg :: Maybe InstalledPackageEx of+          Nothing   -> \_ -> False+          Just ipkg -> \p -> packageId p `elem` depends ipkg+        -- If there is no upper bound on the version range then we apply a+        -- preferred version according to the hackage or user's suggested+        -- version constraints. TODO: distinguish hacks from prefs+        bounded = boundedAbove versionRange+        isPreferred p+          | bounded   = True -- any constant will do+          | otherwise = packageVersion p `withinRange` preferredVersions+          where (PackagePreferences preferredVersions _) = pref (packageName p)++        boundedAbove :: VersionRange -> Bool+        boundedAbove vr = case asVersionIntervals vr of+          []        -> True -- this is the inconsistent version range.+          intervals -> case last intervals of+            (_,   UpperBound _ _) -> True+            (_, NoUpperBound    ) -> False++        -- We really only expect to find more than one choice remaining when+        -- we're finalising a dependency on a paired package.+        checkIsPaired [p1, p2] =+          case Constraints.isPaired constraints (packageId p1) of+            Just p2'   -> packageId p2' == packageId p2+            Nothing    -> False+        checkIsPaired _ = False++-- | Improve an existing installation plan by, where possible, swapping+-- packages we plan to install with ones that are already installed.+-- This may add additional constraints due to the dependencies of installed+-- packages on other installed packages.+--+improvePlan :: PackageIndex InstalledPackage+            -> Constraints+            -> PackageIndex PlanPackage+            -> (PackageIndex PlanPackage, Constraints)+improvePlan installed constraints0 selected0 =+  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)+  where+    improve (selected, constraints) = fromMaybe (selected, constraints)+                                    . improvePkg selected constraints++    -- The idea is to improve the plan by swapping a configured package for+    -- an equivalent installed one. For a particular package the condition is+    -- that the package be in a configured state, that a the same version be+    -- already installed with the exact same dependencies and all the packages+    -- in the plan that it depends on are in the installed state+    improvePkg selected constraints pkgid = do+      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid+      ipkg            <- PackageIndex.lookupPackageId installed pkgid+      guard $ all (isInstalled selected) (depends pkg)+      tryInstalled selected constraints [ipkg]++    isInstalled selected pkgid =+      case PackageIndex.lookupPackageId selected pkgid of+        Just (PreExisting _) -> True+        _                    -> False++    tryInstalled :: PackageIndex PlanPackage -> Constraints+                 -> [InstalledPackage]+                 -> Maybe (PackageIndex PlanPackage, Constraints)+    tryInstalled selected constraints [] = Just (selected, constraints)+    tryInstalled selected constraints (pkg:pkgs) =+      case constraintsOk (packageId pkg) (depends pkg) constraints of+        Nothing           -> Nothing+        Just constraints' -> tryInstalled selected' constraints' pkgs'+          where+            selected' = PackageIndex.insert (PreExisting pkg) selected+            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs+            notSelected pkgid =+              case (PackageIndex.lookupPackageId installed pkgid+                   ,PackageIndex.lookupPackageId selected  pkgid) of+                (Just pkg', Nothing) -> Just pkg'+                _                    -> Nothing++    constraintsOk _     []              constraints = Just constraints+    constraintsOk pkgid (pkgid':pkgids) constraints =+      case addPackageDependencyConstraint pkgid dep constraints of+        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'+        _                          -> Nothing+      where+        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')++    reverseTopologicalOrder :: PackageFixedDeps pkg+                            => PackageIndex pkg -> [PackageIdentifier]+    reverseTopologicalOrder index = map (packageId . toPkg)+                                  . Graph.topSort+                                  . Graph.transposeG+                                  $ graph+      where (graph, toPkg, _) = PackageIndex.dependencyGraph index++-- ------------------------------------------------------------+-- * Adding and recording constraints+-- ------------------------------------------------------------++addPackageSelectConstraint :: PackageIdentifier -> Constraints+                           -> Satisfiable Constraints+                                [PackageIdentifier] ExclusionReason+addPackageSelectConstraint pkgid constraints =+  Constraints.constrain dep reason constraints+  where+    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)+    reason = SelectedOther pkgid++addPackageExcludeConstraint :: PackageIdentifier -> Constraints+                            -> Satisfiable Constraints+                                 [PackageIdentifier] ExclusionReason+addPackageExcludeConstraint pkgid constraints =+  Constraints.constrain dep reason constraints+  where+    dep    = TaggedDependency NoInstalledConstraint+               (notThisPackageVersion pkgid)+    reason = ExcludedByConfigureFail++addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints+                               -> Satisfiable Constraints+                                    [PackageIdentifier] ExclusionReason+addPackageDependencyConstraint pkgid dep constraints =+  Constraints.constrain dep reason constraints+  where+    reason = ExcludedByPackageDependency pkgid dep++addTopLevelVersionConstraint :: PackageName -> VersionRange+                             -> Constraints+                             -> Satisfiable Constraints+                                  [PackageIdentifier] ExclusionReason+addTopLevelVersionConstraint pkg ver constraints =+  Constraints.constrain taggedDep reason constraints+  where+    dep       = Dependency pkg ver+    taggedDep = TaggedDependency NoInstalledConstraint dep+    reason    = ExcludedByTopLevelDependency dep++addTopLevelInstalledConstraint :: PackageName+                               -> Constraints+                               -> Satisfiable Constraints+                                    [PackageIdentifier] ExclusionReason+addTopLevelInstalledConstraint pkg constraints =+  Constraints.constrain taggedDep reason constraints+  where+    dep       = Dependency pkg anyVersion+    taggedDep = TaggedDependency InstalledConstraint dep+    reason    = ExcludedByTopLevelDependency dep++-- ------------------------------------------------------------+-- * Reasons for constraints+-- ------------------------------------------------------------++-- | For every constraint we record we also record the reason that constraint+-- is needed. So if we end up failing due to conflicting constraints then we+-- can give an explnanation as to what was conflicting and why.+--+data ExclusionReason =++     -- | We selected this other version of the package. That means we exclude+     -- all the other versions.+     SelectedOther PackageIdentifier++     -- | We excluded this version of the package because it failed to+     -- configure probably because of unsatisfiable deps.+   | ExcludedByConfigureFail++     -- | We excluded this version of the package because another package that+     -- we selected imposed a dependency which this package did not satisfy.+   | ExcludedByPackageDependency PackageIdentifier TaggedDependency++     -- | We excluded this version of the package because it did not satisfy+     -- a dependency given as an original top level input.+     --+   | ExcludedByTopLevelDependency Dependency++-- | Given an excluded package and the reason it was excluded, produce a human+-- readable explanation.+--+showExclusionReason :: PackageIdentifier -> ExclusionReason -> String+showExclusionReason pkgid (SelectedOther pkgid') =+  display pkgid ++ " was excluded because " +++  display pkgid' ++ " was selected instead"+showExclusionReason pkgid ExcludedByConfigureFail =+  display pkgid ++ " was excluded because it could not be configured"+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =+  display pkgid ++ " was excluded because " +++  display pkgid' ++ " requires " ++ displayDep (untagDependency dep)+showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =+  display pkgid ++ " was excluded because of the top level dependency " +++  displayDep dep+++-- ------------------------------------------------------------+-- * Logging progress and failures+-- ------------------------------------------------------------++data Log = Select [SelectedPackage] [PackageIdentifier]+data Failure+   = ConfigureFailed+       SelectablePackage+       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]+   | DependencyConflict+       SelectedPackage TaggedDependency+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelVersionConstraintConflict+       PackageName VersionRange+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelVersionConstraintUnsatisfiable+       PackageName VersionRange+   | TopLevelInstallConstraintConflict+       PackageName+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelInstallConstraintUnsatisfiable+       PackageName++showLog :: Log -> String+showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of+  ("", y) -> y+  (x, "") -> x+  (x,  y) -> x ++ " and " ++ y++  where+    selectedMsg  = "selecting " ++ case selected of+      []     -> ""+      [s]    -> display (packageId s) ++ " " ++ kind s+      (s:ss) -> listOf id+              $ (display (packageId s) ++ " " ++ kind s)+              : [ display (packageVersion s') ++ " " ++ kind s'+                | s' <- ss ]++    kind (InstalledOnly _)           = "(installed)"+    kind (AvailableOnly _)           = "(hackage)"+    kind (InstalledAndAvailable _ _) = "(installed or hackage)"++    discardedMsg = case discarded of+      []  -> ""+      _   -> "discarding " ++ listOf id+        [ element+        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)+        , element <- display pkgid : map (display . packageVersion) pkgids ]++showFailure :: Failure -> String+showFailure (ConfigureFailed pkg missingDeps) =+     "cannot configure " ++ displayPkg pkg ++ ". It requires "+  ++ listOf (displayDep . fst) missingDeps+  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)++  where+    whyNot (Dependency name ver) [] =+         "There is no available version of " ++ display name+      ++ " that satisfies " ++ displayVer ver++    whyNot dep conflicts =+         "For the dependency on " ++ displayDep dep+      ++ " there are these packages: " ++ listOf display pkgs+      ++ ". However none of them are available.\n"+      ++ unlines [ showExclusionReason (packageId pkg') reason+                 | (pkg', reasons) <- conflicts, reason <- reasons ]++      where pkgs = map fst conflicts++showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =+     "dependencies conflict: "+  ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelVersionConstraintConflict name ver conflicts) =+     "constraints conflict: "+  ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =+     "There is no available version of " ++ display name+      ++ " that satisfies " ++ displayVer ver++showFailure (TopLevelInstallConstraintConflict name conflicts) =+     "constraints conflict: "+  ++ "top level constraint " ++ display name ++ "-installed however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name) =+     "There is no installed version of " ++ display name++displayVer :: VersionRange -> String+displayVer = display . simplifyVersionRange++displayDep :: Dependency -> String+displayDep = display . simplifyDependency++simplifyDependency :: Dependency -> Dependency+simplifyDependency (Dependency name range) =+  Dependency name (simplifyVersionRange range)++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++impossible :: a+impossible = internalError "impossible"++internalError :: String -> a+internalError msg = error $ "internal error: " ++ msg++displayPkg :: Package pkg => pkg -> String+displayPkg = display . packageId++listOf :: (a -> String) -> [a] -> String+listOf _    []   = []+listOf disp [x0] = disp x0+listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs+  where go x []       = " and " ++ disp x+        go x (x':xs') = ", " ++ disp x ++ go x' xs'
+ Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -0,0 +1,316 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Constraints+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A set of satisfiable dependencies (package version constraints).+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Constraints (+  Constraints,+  empty,+  choices,+  isPaired,++  constrain,+  Satisfiable(..),+  conflicting,+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Package+         ( PackageName, PackageIdentifier(..)+         , Package(packageId), packageName, packageVersion+         , PackageFixedDeps(depends)+         , Dependency(Dependency) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )++import Data.List+         ( foldl' )+import Data.Monoid+         ( Monoid(mempty) )+import Data.Maybe+         ( catMaybes )+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Exception+         ( assert )++-- | A set of constraints on package versions. For each package name we record+-- what other packages depends on it and what constraints they impose on the+-- version of the package.+--+data (Package installed, Package available)+  => Constraints installed available reason+   = Constraints++       -- Remaining available choices+       (PackageIndex (InstalledOrAvailable installed available))++       -- Paired choices+       (Map PackageName (Version, Version))++       -- Choices that we have excluded for some reason+       -- usually by applying constraints+       (PackageIndex (ExcludedPackage PackageIdentifier reason))++       -- Purely for the invariant, we keep a copy of the original index+       (PackageIndex (InstalledOrAvailable installed available))+++data ExcludedPackage pkg reason+   = ExcludedPackage pkg [reason] -- reasons for excluding just the available+                         [reason] -- reasons for excluding installed and avail++instance Package pkg => Package (ExcludedPackage pkg reason) where+  packageId (ExcludedPackage p _ _) = packageId p++-- | There is a conservation of packages property. Packages are never gained or+-- lost, they just transfer from the remaining pot to the excluded pot.+--+invariant :: (Package installed, Package available)+          => Constraints installed available a -> Bool+invariant (Constraints available _ excluded original) = all check merged+  where+    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)+                     (PackageIndex.allPackages original)+                     (mergeBy (\a b -> packageId a `compare` packageId b)+                              (PackageIndex.allPackages available)+                              (PackageIndex.allPackages excluded))+      where+        mergedPackageId (OnlyInLeft  p  ) = packageId p+        mergedPackageId (OnlyInRight   p) = packageId p+        mergedPackageId (InBoth      p _) = packageId p++    check (InBoth (InstalledOnly _) cur) = case cur of+      -- If the package was originally installed only then+      -- now it's either still remaining as installed only+      -- or it has been excluded in which case we excluded both+      -- installed and available since it was only installed+      OnlyInLeft  (InstalledOnly _)            -> True+      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True+      _                                        -> False++    check (InBoth (AvailableOnly _) cur) = case cur of+      -- If the package was originally available only then+      -- now it's either still remaining as available only+      -- or it has been excluded in which case we excluded both+      -- installed and available since it was only available+      OnlyInLeft  (AvailableOnly   _)          -> True+      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True+      _                                        -> True++    -- If the package was originally installed and available+    -- then there are three cases.+    check (InBoth (InstalledAndAvailable _ _) cur) = case cur of+      -- We can have both remaining:+      OnlyInLeft                    (InstalledAndAvailable _ _)  -> True+      -- both excluded, in particular it can have had the available excluded+      -- and later had both excluded so we do not mind if the available excluded+      -- is empty or non-empty.+      OnlyInRight                   (ExcludedPackage _ _  (_:_)) -> True+      -- the installed remaining and the available excluded:+      InBoth      (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True+      _                                                          -> False++    check _ = False++-- | An update to the constraints can move packages between the two piles+-- but not gain or loose packages.+transitionsTo :: (Package installed, Package available)+              => Constraints installed available a+              -> Constraints installed available a -> Bool+transitionsTo constraints @(Constraints available  _ excluded  _)+              constraints'@(Constraints available' _ excluded' _) =+     invariant constraints && invariant constraints'+  && null availableGained  && null excludedLost+  && map packageId availableLost == map packageId excludedGained++  where+    availableLost   = foldr lost [] availableChange where+      lost (OnlyInLeft  pkg)          rest = pkg : rest+      lost (InBoth (InstalledAndAvailable _ pkg)+                   (InstalledOnly _)) rest = AvailableOnly pkg : rest+      lost _                          rest = rest+    availableGained = [ pkg | OnlyInRight pkg <- availableChange ]+    excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]+    excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]+                   ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])+                                 pkg@(ExcludedPackage _ (_:_) (_:_))+                                              <- excludedChange  ]+    availableChange = mergeBy (\a b -> packageId a `compare` packageId b)+                              (PackageIndex.allPackages available)+                              (PackageIndex.allPackages available')+    excludedChange  = mergeBy (\a b -> packageId a `compare` packageId b)+                              (PackageIndex.allPackages excluded)+                              (PackageIndex.allPackages excluded')++-- | We construct 'Constraints' with an initial 'PackageIndex' of all the+-- packages available.+--+empty :: (PackageFixedDeps installed, Package available)+      => PackageIndex installed+      -> PackageIndex available+      -> Constraints installed available reason+empty installed available = Constraints pkgs pairs mempty pkgs+  where+    pkgs = PackageIndex.fromList+         . map toInstalledOrAvailable+         $ mergeBy (\a b -> packageId a `compare` packageId b)+                   (PackageIndex.allPackages installed)+                   (PackageIndex.allPackages available)+    toInstalledOrAvailable (OnlyInLeft  i  ) = InstalledOnly         i+    toInstalledOrAvailable (OnlyInRight   a) = AvailableOnly           a+    toInstalledOrAvailable (InBoth      i a) = InstalledAndAvailable i a++    -- pick up cases like base-3 and 4 where one version depends on the other:+    pairs = Map.fromList+      [ (name, (packageVersion pkgid1, packageVersion pkgid2))+      | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed+      , let name   = packageName pkg1+            pkgid1 = packageId pkg1+            pkgid2 = packageId pkg2+      ,    any ((pkgid1==) . packageId) (depends pkg2)+        || any ((pkgid2==) . packageId) (depends pkg1) ]++-- | The package choices that are still available.+--+choices :: (Package installed, Package available)+        => Constraints installed available reason+        -> PackageIndex (InstalledOrAvailable installed available)+choices (Constraints available _ _ _) = available++isPaired :: (Package installed, Package available)+         => Constraints installed available reason+         -> PackageIdentifier -> Maybe PackageIdentifier+isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =+  case Map.lookup name pairs of+    Just (v1, v2)+      | version == v1 -> Just (PackageIdentifier name v2)+      | version == v2 -> Just (PackageIdentifier name v1)+    _                 -> Nothing++data Satisfiable constraints discarded reason+       = Satisfiable constraints discarded+       | Unsatisfiable+       | ConflictsWith [(PackageIdentifier, [reason])]++constrain :: (Package installed, Package available)+          => TaggedDependency+          -> reason+          -> Constraints installed available reason+          -> Satisfiable (Constraints installed available reason)+                         [PackageIdentifier] reason+constrain (TaggedDependency installedConstraint (Dependency name versionRange))+          reason constraints@(Constraints available paired excluded original)++  | not anyRemaining+  = if null conflicts then Unsatisfiable+                      else ConflictsWith conflicts++  | otherwise+  = let constraints' = Constraints available' paired excluded' original+     in assert (constraints `transitionsTo` constraints') $+        Satisfiable constraints' (map packageId newExcluded)++  where+  -- This tells us if any packages would remain at all for this package name if+  -- we applied this constraint. This amounts to checking if any package+  -- satisfies the given constraint, including version range and installation+  -- status.+  --+  anyRemaining = any satisfiesConstraint availableChoices++  conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)+              | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices+              , satisfiesVersionConstraint pkg ]++  -- Applying this constraint may involve deleting some choices for this+  -- package name, or restricting which install states are available.+  available' = updateAvailable available+  updateAvailable = flip (foldl' (flip update)) availableChoices where+    update pkg | not (satisfiesVersionConstraint pkg)+               = PackageIndex.deletePackageId (packageId pkg)+    update _   | installedConstraint == NoInstalledConstraint+               = id+    update pkg = case pkg of+      InstalledOnly         _   -> id+      AvailableOnly           _ -> PackageIndex.deletePackageId (packageId pkg)+      InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)++  -- Applying the constraint means adding exclusions for the packages that+  -- we're just freshly excluding, ie the ones we're removing from available.+  excluded' = foldl' (flip PackageIndex.insert) excluded+                (newExcluded ++ oldExcluded)++  newExcluded = catMaybes (map exclude availableChoices) where+    exclude pkg+      | not (satisfiesVersionConstraint pkg)+      = Just (ExcludedPackage pkgid [] [reason])+      | installedConstraint == NoInstalledConstraint+      = Nothing+      | otherwise = case pkg of+      InstalledOnly         _   -> Nothing+      AvailableOnly           _ -> Just (ExcludedPackage pkgid [] [reason])+      InstalledAndAvailable _ _ ->+        case PackageIndex.lookupPackageId excluded pkgid of+          Just (ExcludedPackage _ avail both)+                  -> Just (ExcludedPackage pkgid (reason:avail) both)+          Nothing -> Just (ExcludedPackage pkgid [reason] [])+      where pkgid = packageId pkg++  -- Additionally we have to add extra exclusions for any already-excluded+  -- packages that happen to be covered by the (inverse of the) constraint.+  oldExcluded = catMaybes (map exclude excludedChoices) where+    exclude (ExcludedPackage pkgid avail both)+      -- if it doesn't satisfy the version constraint then we exclude the+      -- package as a whole, the available or the installed instances or both.+      | not (satisfiesVersionConstraint pkgid)+      = Just (ExcludedPackage pkgid avail (reason:both))+      -- if on the other hand it does satisfy the constraint and we were also+      -- constraining to just the installed version then we exclude just the+      -- available instance.+      | installedConstraint == InstalledConstraint+      = Just (ExcludedPackage pkgid (reason:avail) both)+      | otherwise = Nothing++  -- util definitions+  availableChoices = PackageIndex.lookupPackageName available name+  excludedChoices  = PackageIndex.lookupPackageName excluded  name++  satisfiesConstraint pkg = satisfiesVersionConstraint pkg+                         && satisfiesInstallStateConstraint pkg++  satisfiesVersionConstraint :: Package pkg => pkg -> Bool+  satisfiesVersionConstraint = case Map.lookup name paired of+    Nothing       -> \pkg ->+      packageVersion pkg `withinRange` versionRange+    Just (v1, v2) -> \pkg -> case packageVersion pkg of+      v | v == v1+       || v == v2   -> v1 `withinRange` versionRange+                    || v2 `withinRange` versionRange+        | otherwise -> v `withinRange` versionRange++  satisfiesInstallStateConstraint = case installedConstraint of+    NoInstalledConstraint -> \_   -> True+    InstalledConstraint   -> \pkg -> case pkg of+      AvailableOnly _             -> False+      _                           -> True++conflicting :: (Package installed, Package available)+            => Constraints installed available reason+            -> Dependency+            -> [(PackageIdentifier, [reason])]+conflicting (Constraints _ _ excluded _) dep =+  [ (pkgid, reasonsAvail ++ reasonsAll) --TODO+  | ExcludedPackage pkgid reasonsAvail reasonsAll <-+      PackageIndex.lookupDependency excluded dep ]
+ Distribution/Client/Dependency/TopDown/Types.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Types for the top-down dependency resolver.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Types where++import Distribution.Client.Types+         ( AvailablePackage(..), InstalledPackage )++import Distribution.Package+         ( PackageIdentifier, Dependency+         , Package(packageId), PackageFixedDeps(depends) )+import Distribution.PackageDescription+         ( FlagAssignment )++-- ------------------------------------------------------------+-- * The various kinds of packages+-- ------------------------------------------------------------++type SelectablePackage+   = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage++type SelectedPackage+   = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage++data InstalledOrAvailable installed available+   = InstalledOnly         installed+   | AvailableOnly                   available+   | InstalledAndAvailable installed available++type TopologicalSortNumber = Int++data InstalledPackageEx+   = InstalledPackageEx+       InstalledPackage+       !TopologicalSortNumber+       [PackageIdentifier]    -- transative closure of installed deps++data UnconfiguredPackage+   = UnconfiguredPackage+       AvailablePackage+       !TopologicalSortNumber+       FlagAssignment++data SemiConfiguredPackage+   = SemiConfiguredPackage+       AvailablePackage  -- package info+       FlagAssignment    -- total flag assignment for the package+       [Dependency]      -- dependencies we end up with when we apply+                         -- the flag assignment++instance Package InstalledPackageEx where+  packageId (InstalledPackageEx p _ _) = packageId p++instance PackageFixedDeps InstalledPackageEx where+  depends (InstalledPackageEx _ _ deps) = deps++instance Package UnconfiguredPackage where+  packageId (UnconfiguredPackage p _ _) = packageId p++instance Package SemiConfiguredPackage where+  packageId (SemiConfiguredPackage p _ _) = packageId p++instance (Package installed, Package available)+      => Package (InstalledOrAvailable installed available) where+  packageId (InstalledOnly         p  ) = packageId p+  packageId (AvailableOnly         p  ) = packageId p+  packageId (InstalledAndAvailable p _) = packageId p++-- ------------------------------------------------------------+-- * Tagged Dependency type+-- ------------------------------------------------------------++-- | Installed packages can only depend on other installed packages while+-- packages that are not yet installed but which we plan to install can depend+-- on installed or other not-yet-installed packages.+--+-- This makes life more complex as we have to remember these constraints.+--+data TaggedDependency = TaggedDependency InstalledConstraint Dependency+data InstalledConstraint = InstalledConstraint | NoInstalledConstraint+  deriving Eq++untagDependency :: TaggedDependency -> Dependency+untagDependency (TaggedDependency _ dep) = dep
+ Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.Types (+    DependencyResolver,++    PackageConstraint(..),+    PackagePreferences(..),+    InstalledPreference(..),++    Progress(..),+    foldProgress,+  ) where++import Distribution.Client.Types+         ( AvailablePackage(..), InstalledPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.PackageDescription+         ( FlagAssignment )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import Distribution.Package+         ( PackageName )+import Distribution.Version+         ( VersionRange )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( Platform )++import Prelude hiding (fail)++-- | A dependency resolver is a function that works out an installation plan+-- given the set of installed and available packages and a set of deps to+-- solve for.+--+-- The reason for this interface is because there are dozens of approaches to+-- solving the package dependency problem and we want to make it easy to swap+-- in alternatives.+--+type DependencyResolver = Platform+                       -> CompilerId+                       -> PackageIndex InstalledPackage+                       -> PackageIndex AvailablePackage+                       -> (PackageName -> PackagePreferences)+                       -> [PackageConstraint]+                       -> [PackageName]+                       -> Progress String String [InstallPlan.PlanPackage]++-- | Per-package constraints. Package constraints must be respected by the+-- solver. Multiple constraints for each package can be given, though obviously+-- it is possible to construct conflicting constraints (eg impossible version+-- range or inconsistent flag assignment).+--+data PackageConstraint+   = PackageVersionConstraint   PackageName VersionRange+   | PackageInstalledConstraint PackageName+   | PackageFlagsConstraint     PackageName FlagAssignment+  deriving (Show,Eq)++-- | A per-package preference on the version. It is a soft constraint that the+-- 'DependencyResolver' should try to respect where possible. It consists of+-- a 'InstalledPreference' which says if we prefer versions of packages+-- that are already installed. It also hase a 'PackageVersionPreference' which+-- is a suggested constraint on the version number. The resolver should try to+-- use package versions that satisfy the suggested version constraint.+--+-- It is not specified if preferences on some packages are more important than+-- others.+--+data PackagePreferences = PackagePreferences VersionRange InstalledPreference++-- | Wether we prefer an installed version of a package or simply the latest+-- version.+--+data InstalledPreference = PreferInstalled | PreferLatest++-- | A type to represent the unfolding of an expensive long running+-- calculation that may fail. We may get intermediate steps before the final+-- retult which may be used to indicate progress and\/or logging messages.+--+data Progress step fail done = Step step (Progress step fail done)+                             | Fail fail+                             | Done done++-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with+-- two base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step fail done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = fail f+        fold (Done r)   = done r++instance Functor (Progress step fail) where+  fmap f = foldProgress Step Fail (Done . f)++instance Monad (Progress step fail) where+  return a = Done a+  p >>= f  = foldProgress Step Fail f p
+ Distribution/Client/Fetch.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Fetch+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal fetch command+-----------------------------------------------------------------------------+module Distribution.Client.Fetch (+    fetch,+  ) where++import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.FetchUtils hiding (fetchPackage)+import Distribution.Client.Dependency+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, getInstalledPackages )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FetchFlags(..) )++import Distribution.Package+         ( packageId )+import Distribution.Simple.Compiler+         ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Simple.Utils+         ( die, notice, debug )+import Distribution.System+         ( buildPlatform )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Control.Monad+         ( filterM )++-- ------------------------------------------------------------+-- * The fetch command+-- ------------------------------------------------------------++--TODO:+-- * add fetch -o support+-- * support tarball URLs via ad-hoc download cache (or in -o mode?)+-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied+-- * Port various flags from install:+--   * --updage-dependencies+--   * --constraint and --preference+--   * --only-dependencies, but note it conflicts with --no-deps+++-- | Fetch a list of packages and their dependencies.+--+fetch :: Verbosity+      -> PackageDBStack+      -> [Repo]+      -> Compiler+      -> ProgramConfiguration+      -> GlobalFlags+      -> FetchFlags+      -> [UserTarget]+      -> IO ()+fetch verbosity _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++fetch verbosity packageDBs repos comp conf+      globalFlags fetchFlags userTargets = do++    mapM_ checkTarget userTargets++    installed     <- getInstalledPackages verbosity comp packageDBs conf+    availableDb   <- getAvailablePackages verbosity repos++    pkgSpecifiers <- resolveUserTargets verbosity+                       globalFlags (packageIndex availableDb) userTargets++    pkgs  <- planPackages+               verbosity comp fetchFlags+               installed availableDb pkgSpecifiers++    pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs+    if null pkgs'+      --TODO: when we add support for remote tarballs then this message+      -- will need to be changed because for remote tarballs we fetch them+      -- at the earlier phase.+      then notice verbosity $ "No packages need to be fetched. "+                           ++ "All the requested packages are already local "+                           ++ "or cached locally."+      else if dryRun+             then notice verbosity $ unlines $+                     "The following packages would be fetched:"+                   : map (display . packageId) pkgs'++             else mapM_ (fetchPackage verbosity . packageSource) pkgs'++  where+    dryRun = fromFlag (fetchDryRun fetchFlags)++planPackages :: Verbosity+             -> Compiler+             -> FetchFlags+             -> PackageIndex InstalledPackage+             -> AvailablePackageDb+             -> [PackageSpecifier AvailablePackage]+             -> IO [AvailablePackage]+planPackages verbosity comp fetchFlags+             installed availableDb pkgSpecifiers++  | includeDependencies = do+      notice verbosity "Resolving dependencies..."+      installPlan <- foldProgress logMsg die return $+                       resolveDependencies+                         buildPlatform (compilerId comp)+                         resolverParams++      -- The packages we want to fetch are those packages the 'InstallPlan'+      -- that are in the 'InstallPlan.Configured' state.+      return+        [ pkg+        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))+            <- InstallPlan.toList installPlan ]++  | otherwise =+      either (die . unlines . map show) return $+        resolveWithoutDependencies resolverParams++  where+    resolverParams =++        -- Reinstall the targets given on the command line so that the dep+        -- resolver will decide that they need fetching, even if they're+        -- already installed. Sicne we want to get the source packages of+        -- things we might have installed (but not have the sources for).+        reinstallTargets++      $ standardInstallPolicy installed availableDb pkgSpecifiers++    includeDependencies = fromFlag (fetchDeps fetchFlags)+    logMsg message rest = debug verbosity message >> rest+++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetRemoteTarball _uri+      -> die $ "The 'fetch' command does not yet support remote tarballs. "+            ++ "In the meantime you can use the 'unpack' commands."+    _ -> return ()++fetchPackage :: Verbosity -> PackageLocation a -> IO ()+fetchPackage verbosity pkgsrc = case pkgsrc of+    LocalUnpackedPackage _dir  -> return ()+    LocalTarballPackage  _file -> return ()++    RemoteTarballPackage _uri _ ->+      die $ "The 'fetch' command does not yet support remote tarballs. "+         ++ "In the meantime you can use the 'unpack' commands."++    RepoTarballPackage repo pkgid _ -> do+      _ <- fetchRepoTarball verbosity repo pkgid+      return ()
+ Distribution/Client/FetchUtils.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.FetchUtils+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for fetching packages+-----------------------------------------------------------------------------+module Distribution.Client.FetchUtils (++    -- * fetching packages+    fetchPackage,+    isFetched,+    checkFetched,++    -- ** specifically for repo packages+    fetchRepoTarball,++    -- * fetching other things+    downloadIndex,+  ) where++import Distribution.Client.Types+import Distribution.Client.HttpUtils+         ( downloadURI, isOldHackageURI )++import Distribution.Package+         ( PackageId, packageName, packageVersion )+import Distribution.Simple.Utils+         ( notice, info, setupMessage )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Data.Maybe+import System.Directory+         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.IO+         ( openTempFile, hClose )+import System.FilePath+         ( (</>), (<.>) )+import qualified System.FilePath.Posix as FilePath.Posix+         ( combine, joinPath )+import Network.URI+         ( URI(uriPath) )++-- ------------------------------------------------------------+-- * Actually fetch things+-- ------------------------------------------------------------++-- | Returns @True@ if the package has already been fetched+-- or does not need fetching.+--+isFetched :: PackageLocation (Maybe FilePath) -> IO Bool+isFetched loc = case loc of+    LocalUnpackedPackage _dir       -> return True+    LocalTarballPackage  _file      -> return True+    RemoteTarballPackage _uri local -> return (isJust local)+    RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)+++checkFetched :: PackageLocation (Maybe FilePath)+             -> IO (Maybe (PackageLocation FilePath))+checkFetched loc = case loc of+    LocalUnpackedPackage dir  ->+      return (Just $ LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (Just $ LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (Just $ RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (Just $ RepoTarballPackage repo pkgid file)++    RemoteTarballPackage _uri Nothing -> return Nothing+    RepoTarballPackage repo pkgid Nothing -> do+      let file = packageFile repo pkgid+      exists <- doesFileExist file+      if exists+        then return (Just $ RepoTarballPackage repo pkgid file)+        else return Nothing+++-- | Fetch a package if we don't have it already.+--+fetchPackage :: Verbosity+             -> PackageLocation (Maybe FilePath)+             -> IO (PackageLocation FilePath)+fetchPackage verbosity loc = case loc of+    LocalUnpackedPackage dir  ->+      return (LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (RepoTarballPackage repo pkgid file)++    RemoteTarballPackage uri Nothing -> do+      path <- downloadTarballPackage uri+      return (RemoteTarballPackage uri path)+    RepoTarballPackage repo pkgid Nothing -> do+      local <- fetchRepoTarball verbosity repo pkgid+      return (RepoTarballPackage repo pkgid local)+  where+    downloadTarballPackage uri = do+      notice verbosity ("Downloading " ++ show uri)+      tmpdir <- getTemporaryDirectory+      (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"+      hClose hnd+      downloadURI verbosity uri path+      return path+++-- | Fetch a repo package if we don't have it already.+--+fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity repo pkgid = do+  fetched <- doesFileExist (packageFile repo pkgid)+  if fetched+    then do info verbosity $ display pkgid ++ " has already been downloaded."+            return (packageFile repo pkgid)+    else do setupMessage verbosity "Downloading" pkgid+            downloadRepoPackage+  where+    downloadRepoPackage = case repoKind repo of+      Right LocalRepo -> return (packageFile repo pkgid)++      Left remoteRepo -> do+        let uri  = packageURI remoteRepo pkgid+            dir  = packageDir       repo pkgid+            path = packageFile      repo pkgid+        createDirectoryIfMissing True dir+        downloadURI verbosity uri path+        return path++-- | Downloads an index file to [config-dir/packages/serv-id].+--+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex verbosity repo cacheDir = do+  let uri = (remoteRepoURI repo) {+              uriPath = uriPath (remoteRepoURI repo)+                          `FilePath.Posix.combine` "00-index.tar.gz"+            }+      path = cacheDir </> "00-index" <.> "tar.gz"+  createDirectoryIfMissing True cacheDir+  downloadURI verbosity uri path+  return path+++-- ------------------------------------------------------------+-- * Path utilities+-- ------------------------------------------------------------++-- | Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+--+packageFile :: Repo -> PackageId -> FilePath+packageFile repo pkgid = packageDir repo pkgid+                     </> display pkgid+                     <.> "tar.gz"++-- | Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+--+packageDir :: Repo -> PackageId -> FilePath+packageDir repo pkgid = repoLocalDir repo+                    </> display (packageName    pkgid)+                    </> display (packageVersion pkgid)++-- | Generate the URI of the tarball for a given package.+--+packageURI :: RemoteRepo -> PackageId -> URI+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,display (packageName    pkgid)+      ,display (packageVersion pkgid)+      ,display pkgid <.> "tar.gz"]+  }+packageURI repo pkgid =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,"package"+      ,display pkgid <.> "tar.gz"]+  }
+ Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GZipUtils+-- Copyright   :  (c) Dmitry Astapov 2010+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Provides a convenience functions for working with files that may or may not+-- be zipped.+-----------------------------------------------------------------------------+module Distribution.Client.GZipUtils (+    maybeDecompress,+  ) where++import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..))+import Data.ByteString.Lazy (ByteString)+import Codec.Compression.GZip+import Codec.Compression.Zlib.Internal++-- | Attempts to decompress the `bytes' under the assumption that+-- "data format" error at the very beginning of the stream means+-- that it is already decompressed. Caller should make sanity checks+-- to verify that it is not, in fact, garbage.+--+-- This is to deal with http proxies that lie to us and transparently+-- decompress without removing the content-encoding header. See:+-- <http://hackage.haskell.org/trac/hackage/ticket/686>+--+maybeDecompress :: ByteString -> ByteString+maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes+  where+    -- DataError at the beginning of the stream probably means that stream is not compressed.+    -- Returning it as-is.+    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- at the beginning of the gzip header.+    foldStream (StreamError DataError _) = bytes+    foldStream somethingElse = doFold somethingElse++    doFold StreamEnd               = BS.Empty+    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)+    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg
+ Distribution/Client/Haddock.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Haddock+-- Copyright   :  (c) Andrea Vezzosi 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Interfacing with Haddock+--+-----------------------------------------------------------------------------+module Distribution.Client.Haddock +    (+     regenerateHaddockIndex+    )+    where++import Data.Maybe (listToMaybe)+import Data.List (maximumBy)+import Control.Monad (guard)+import System.Directory (createDirectoryIfMissing, doesFileExist,+                         renameFile)+import System.FilePath ((</>), splitFileName)+import Distribution.Package (Package(..))+import Distribution.Simple.Program (haddockProgram, ProgramConfiguration+                                   , rawSystemProgram, requireProgramVersion)+import Distribution.Version (Version(Version), orLaterVersion)+import Distribution.Verbosity (Verbosity)+import Distribution.Text (display)+import Distribution.Client.PackageIndex(PackageIndex, allPackages,+                                        allPackagesByName, fromList)+import Distribution.Simple.Utils+         ( comparing, intercalate, debug+         , installDirectoryContents, withTempDirectory )+import Distribution.InstalledPackageInfo as InstalledPackageInfo +         ( InstalledPackageInfo+         , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )+import Distribution.Client.Types+         ( InstalledPackage(..) )++regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex verbosity pkgs conf index = do+      (paths,warns) <- haddockPackagePaths pkgs'+      case warns of+        Nothing -> return ()+        Just m  -> debug verbosity m+      +      (confHaddock, _, _) <-+          requireProgramVersion verbosity haddockProgram+                                    (orLaterVersion (Version [0,6] [])) conf++      createDirectoryIfMissing True destDir++      withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do++        let flags = [ "--gen-contents"+                    , "--gen-index"+                    , "--odir=" ++ tempDir+                    , "--title=Haskell modules on this system" ]+                 ++ [ "--read-interface=" ++ html ++ "," ++ interface+                    | (interface, html) <- paths ]+        rawSystemProgram verbosity confHaddock flags+        renameFile (tempDir </> "index.html") (tempDir </> destFile)+        installDirectoryContents verbosity tempDir destDir+      +  where +    (destDir,destFile) = splitFileName index+    pkgs' = map (maximumBy $ comparing packageId) +            . allPackagesByName +            . fromList+            . filter exposed+            . map (\(InstalledPackage pkg _) -> pkg)+            . allPackages+            $ pkgs++haddockPackagePaths :: [InstalledPackageInfo]+                       -> IO ([(FilePath, FilePath)], Maybe String)+haddockPackagePaths pkgs = do+  interfaces <- sequence+    [ case interfaceAndHtmlPath pkg of+        Just (interface, html) -> do+          exists <- doesFileExist interface+          if exists+            then return (pkgid, Just (interface, html))+            else return (pkgid, Nothing)+        Nothing -> return (pkgid, Nothing)+    | pkg <- pkgs, let pkgid = packageId pkg ]++  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]++      warning = "The documentation for the following packages are not "+             ++ "installed. No links will be generated to these packages: "+             ++ intercalate ", " (map display missing)++      flags = [ x | (_, Just x) <- interfaces ]++  return (flags, if null missing then Nothing else Just warning)++  where+    interfaceAndHtmlPath pkg = do+      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+      html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+      guard (not . null $ html)+      return (interface, html)
+ Distribution/Client/HttpUtils.hs view
@@ -0,0 +1,197 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- | Separate module for HTTP actions, using a proxy server if one exists+-----------------------------------------------------------------------------+module Distribution.Client.HttpUtils (+    downloadURI,+    getHTTP,+    proxy,+    isOldHackageURI+  ) where++import Network.HTTP+         ( Request (..), Response (..), RequestMethod (..)+         , Header(..), HeaderName(..) )+import Network.URI+         ( URI (..), URIAuth (..), parseAbsoluteURI )+import Network.Stream+         ( Result, ConnError(..) )+import Network.Browser+         ( Proxy (..), Authority (..), browse+         , setOutHandler, setErrHandler, setProxy, request)+import Control.Monad+         ( mplus, join, liftM2 )+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.ByteString.Lazy (ByteString)+#ifdef WIN32+import System.Win32.Types+         ( DWORD, HKEY )+import System.Win32.Registry+         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey+         , regQueryValue, regQueryValueEx )+import Control.Exception+         ( bracket )+import Distribution.Compat.Exception+         ( handleIO )+import Foreign+         ( toBool, Storable(peek, sizeOf), castPtr, alloca )+#endif+import System.Environment (getEnvironment)++import qualified Paths_cabal_install_bundle (version)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+         ( die, info, warn, debug+         , copyFileVerbose, writeFileAtomic )+import Distribution.Text+         ( display )+import qualified System.FilePath.Posix as FilePath.Posix+         ( splitDirectories )++-- FIXME: all this proxy stuff is far too complicated, especially parsing+-- the proxy strings. Network.Browser should have a way to pick up the+-- proxy settings hiding all this system-dependent stuff below.++-- try to read the system proxy settings on windows or unix+proxyString, envProxyString, registryProxyString :: IO (Maybe String)+#ifdef WIN32+-- read proxy settings from the windows registry+registryProxyString = handleIO (\_ -> return Nothing) $+  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do+    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+    if enable+        then fmap Just $ regQueryValue hkey (Just "ProxyServer")+        else return Nothing+  where+    -- some sources say proxy settings should be at+    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+    --                   \CurrentVersion\Internet Settings\ProxyServer+    -- but if the user sets them with IE connection panel they seem to+    -- end up in the following place:+    hive  = hKEY_CURRENT_USER+    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++    regQueryValueDWORD :: HKEY -> String -> IO DWORD+    regQueryValueDWORD hkey name = alloca $ \ptr -> do+      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+      peek ptr+#else+registryProxyString = return Nothing+#endif++-- read proxy settings by looking for an env var+envProxyString = do+  env <- getEnvironment+  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)++proxyString = liftM2 mplus envProxyString registryProxyString+++-- |Get the local proxy settings+proxy :: Verbosity -> IO Proxy+proxy verbosity = do+  mstr <- proxyString+  case mstr of+    Nothing   -> return NoProxy+    Just str  -> case parseHttpProxy str of+      Nothing -> do+        warn verbosity $ "invalid http proxy uri: " ++ show str+        warn verbosity $ "proxy uri must be http with a hostname"+        warn verbosity $ "ignoring http proxy, trying a direct connection"+        return NoProxy+      Just p  -> return p+--TODO: print info message when we're using a proxy++-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+-- which lack the @\"http://\"@ URI scheme. The problem is that+-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+--+-- So our strategy is to try parsing as normal uri first and if it lacks the+-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+--+parseHttpProxy :: String -> Maybe Proxy+parseHttpProxy str = join+                   . fmap uri2proxy+                   $ parseHttpURI str+             `mplus` parseHttpURI ("http://" ++ str)+  where+    parseHttpURI str' = case parseAbsoluteURI str' of+      Just uri@URI { uriAuthority = Just _ }+         -> Just (fixUserInfo uri)+      _  -> Nothing++fixUserInfo :: URI -> URI+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }+    where+      f a@URIAuth{ uriUserInfo = s } =+          a{ uriUserInfo = case reverse s of+                             '@':s' -> reverse s'+                             _      -> s+           }+uri2proxy :: URI -> Maybe Proxy+uri2proxy uri@URI{ uriScheme = "http:"+                 , uriAuthority = Just (URIAuth auth' host port)+                 } = Just (Proxy (host ++ port) auth)+  where auth = if null auth'+                 then Nothing+                 else Just (AuthBasic "" usr pwd uri)+        (usr,pwd') = break (==':') auth'+        pwd        = case pwd' of+                       ':':cs -> cs+                       _      -> pwd'+uri2proxy _ = Nothing++mkRequest :: URI -> Request ByteString+mkRequest uri = Request{ rqURI     = uri+                       , rqMethod  = GET+                       , rqHeaders = [Header HdrUserAgent userAgent]+                       , rqBody    = ByteString.empty }+  where userAgent = "cabal-install/" ++ display Paths_cabal_install_bundle.version++-- |Carry out a GET request, using the local proxy settings+getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))+getHTTP verbosity uri = do+                 p   <- proxy verbosity+                 let req = mkRequest uri+                 (_, resp) <- browse $ do+                                setErrHandler (warn verbosity . ("http error: "++))+                                setOutHandler (debug verbosity)+                                setProxy p+                                request req+                 return (Right resp)++downloadURI :: Verbosity+            -> URI      -- ^ What to download+            -> FilePath -- ^ Where to put it+            -> IO ()+downloadURI verbosity uri path | uriScheme uri == "file:" =+  copyFileVerbose verbosity (uriPath uri) path+downloadURI verbosity uri path = do+  result <- getHTTP verbosity uri+  let result' = case result of+        Left  err -> Left err+        Right rsp -> case rspCode rsp of+          (2,0,0) -> Right (rspBody rsp)+          (a,b,c) -> Left err+            where+              err = ErrorMisc $ "Unsucessful HTTP code: "+                             ++ concatMap show [a,b,c]++  case result' of+    Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err+    Right body -> do+      info verbosity ("Downloaded to " ++ path)+      writeFileAtomic path (ByteString.unpack body)+      --FIXME: check the content-length header matches the body length.+      --TODO: stream the download into the file rather than buffering the whole+      --      thing in memory.+      --      remember the ETag so we can not re-download if nothing changed.++-- Utility function for legacy support.+isOldHackageURI :: URI -> Bool+isOldHackageURI uri+    = case uriAuthority uri of+        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->+            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+        _ -> False
+ Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,265 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Extra utils related to the package indexes.+-----------------------------------------------------------------------------+module Distribution.Client.IndexUtils (+  getInstalledPackages,+  getAvailablePackages,++  readPackageIndexFile,+  parseRepoIndex,+  ) where++import qualified Distribution.Client.Tar as Tar+import Distribution.Client.Types++import Distribution.Package+         ( PackageId, PackageIdentifier(..), PackageName(..)+         , Package(..), packageVersion+         , Dependency(Dependency), InstalledPackageId(..) )+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+import Distribution.PackageDescription+         ( GenericPackageDescription )+import Distribution.PackageDescription.Parse+         ( parsePackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import qualified Distribution.Simple.Configure as Configure+         ( getInstalledPackages )+import Distribution.ParseUtils+         ( ParseResult(..) )+import Distribution.Version+         ( Version(Version), intersectVersionRanges )+import Distribution.Text+         ( simpleParse )+import Distribution.Verbosity+         ( Verbosity, lessVerbose )+import Distribution.Simple.Utils+         ( warn, info, fromUTF8, equating )++import Data.Maybe  (catMaybes, fromMaybe)+import Data.List   (isPrefixOf, groupBy)+import Data.Monoid (Monoid(..))+import qualified Data.Map as Map+import Control.Monad (MonadPlus(mplus), when)+import Control.Exception (evaluate)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import Distribution.Client.GZipUtils (maybeDecompress)+import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.FilePath.Posix as FilePath.Posix+         ( takeFileName )+import System.IO.Error (isDoesNotExistError)+import System.Directory+         ( getModificationTime )+import System.Time+         ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )++getInstalledPackages :: Verbosity -> Compiler+                     -> PackageDBStack -> ProgramConfiguration+                     -> IO (PackageIndex InstalledPackage)+getInstalledPackages verbosity comp packageDbs conf =+    fmap convert (Configure.getInstalledPackages verbosity'+                                                 comp packageDbs conf)+  where+    --FIXME: make getInstalledPackages use sensible verbosity in the first place+    verbosity'  = lessVerbose verbosity++    convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage+    convert index = PackageIndex.fromList+      -- There can be multiple installed instances of each package version,+      -- like when the same package is installed in the global & user dbs.+      -- InstalledPackageIndex.allPackagesByName gives us the installed+      -- packages with the most preferred instances first, so by picking the+      -- first we should get the user one. This is almost but not quite the+      -- same as what ghc does.+      [ InstalledPackage ipkg (sourceDeps index ipkg)+      | ipkgs <- InstalledPackageIndex.allPackagesByName index+      , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]++    -- The InstalledPackageInfo only lists dependencies by the+    -- InstalledPackageId, which means we do not directly know the corresponding+    -- source dependency. The only way to find out is to lookup the+    -- InstalledPackageId to get the InstalledPackageInfo and look at its+    -- source PackageId. But if the package is broken because it depends on+    -- other packages that do not exist then we have a problem we cannot find+    -- the original source package id. Instead we make up a bogus package id.+    -- This should have the same effect since it should be a dependency on a+    -- non-existant package.+    sourceDeps index ipkg =+      [ maybe (brokenPackageId depid) packageId mdep+      | let depids = InstalledPackageInfo.depends ipkg+            getpkg = InstalledPackageIndex.lookupInstalledPackageId index+      , (depid, mdep) <- zip depids (map getpkg depids) ]++    brokenPackageId (InstalledPackageId str) =+      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])++-- | Read a repository index from disk, from the local files specified by+-- a list of 'Repo's.+--+-- All the 'AvailablePackage's are marked as having come from the appropriate+-- 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+--+getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb+getAvailablePackages verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+  return AvailablePackageDb {+    packageIndex       = mempty,+    packagePreferences = mempty+  }+getAvailablePackages verbosity repos = do+  info verbosity "Reading available packages..."+  pkgss <- mapM (readRepoIndex verbosity) repos+  let (pkgs, prefs) = mconcat pkgss+      prefs' = Map.fromListWith intersectVersionRanges+                 [ (name, range) | Dependency name range <- prefs ]+  _ <- evaluate pkgs+  _ <- evaluate prefs'+  return AvailablePackageDb {+    packageIndex       = pkgs,+    packagePreferences = prefs'+  }++-- | Read a repository index from disk, from the local file specified by+-- the 'Repo'.+--+-- All the 'AvailablePackage's are marked as having come from the given 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+--+readRepoIndex :: Verbosity -> Repo+              -> IO (PackageIndex AvailablePackage, [Dependency])+readRepoIndex verbosity repo = handleNotFound $ do+  let indexFile = repoLocalDir repo </> "00-index.tar"+  (pkgs, prefs) <- either fail return+                 . foldlTarball extract ([], [])+               =<< BS.readFile indexFile++  pkgIndex <- evaluate $ PackageIndex.fromList+    [ AvailablePackage {+        packageInfoId      = pkgid,+        packageDescription = pkg,+        packageSource      = RepoTarballPackage repo pkgid Nothing+      }+    | (pkgid, pkg) <- pkgs]++  warnIfIndexIsOld indexFile+  return (pkgIndex, prefs)++  where+    extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $+              (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))+      `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))++    extractPrefs :: Tar.Entry -> Maybe [Dependency]+    extractPrefs entry = case Tar.entryContent entry of+      Tar.NormalFile content _+         | takeFileName (Tar.entryPath entry) == "preferred-versions"+        -> Just . parsePreferredVersions+         . BS.Char8.unpack $ content+      _ -> Nothing++    handleNotFound action = catch action $ \e -> if isDoesNotExistError e+      then do+        case repoKind repo of+          Left  remoteRepo -> warn verbosity $+               "The package list for '" ++ remoteRepoName remoteRepo+            ++ "' does not exist. Run 'cabal update' to download it."+          Right _localRepo -> warn verbosity $+               "The package list for the local repo '" ++ repoLocalDir repo+            ++ "' is missing. The repo is invalid."+        return mempty+      else ioError e++    isOldThreshold = 15 --days+    warnIfIndexIsOld indexFile = do+      indexTime   <- getModificationTime indexFile+      currentTime <- getClockTime+      let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)+      when (tdDay diff >= isOldThreshold) $ case repoKind repo of+        Left  remoteRepo -> warn verbosity $+             "The package list for '" ++ remoteRepoName remoteRepo+          ++ "' is " ++ show (tdDay diff)  ++ " days old.\nRun "+          ++ "'cabal update' to get the latest list of available packages."+        Right _localRepo -> return ()++parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions = catMaybes+                       . map simpleParse+                       . filter (not . isPrefixOf "--")+                       . lines++-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.+--+-- This is supposed to be an \"all in one\" way to easily get at the info in+-- the hackage package index.+--+-- It takes a function to map a 'GenericPackageDescription' into any more+-- specific instance of 'Package' that you might want to use. In the simple+-- case you can just use @\_ p -> p@ here.+--+readPackageIndexFile :: Package pkg+                     => (PackageId -> GenericPackageDescription -> pkg)+                     -> FilePath -> IO (PackageIndex pkg)+readPackageIndexFile mkPkg indexFile = do+  pkgs <- either fail return+        . parseRepoIndex+        . maybeDecompress+      =<< BS.readFile indexFile+  +  evaluate $ PackageIndex.fromList+   [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]++-- | Parse an uncompressed \"00-index.tar\" repository index file represented+-- as a 'ByteString'.+--+parseRepoIndex :: ByteString+               -> Either String [(PackageId, GenericPackageDescription)]+parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []++extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)+extractPkg entry = case Tar.entryContent entry of+  Tar.NormalFile content _+     | takeExtension fileName == ".cabal"+    -> case splitDirectories (normalise fileName) of+        [pkgname,vers,_] -> case simpleParse vers of+          Just ver -> Just (pkgid, descr)+            where+              pkgid  = PackageIdentifier (PackageName pkgname) ver+              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+                                               $ content+              descr  = case parsed of+                ParseOk _ d -> d+                _           -> error $ "Couldn't read cabal file "+                                    ++ show fileName+          _ -> Nothing+        _ -> Nothing+  _ -> Nothing+  where+    fileName = Tar.entryPath entry++foldlTarball :: (a -> Tar.Entry -> a) -> a+             -> ByteString -> Either String a+foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read+  where+    check _  (Tar.Fail err)  = Left  err+    check ok Tar.Done        = Right ok+    check ok (Tar.Next e es) = check (e:ok) es
+ Distribution/Client/Init.hs view
@@ -0,0 +1,556 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init (++    -- * Commands+    initCabal++  ) where++import System.IO+  ( hSetBuffering, stdout, BufferMode(..) )+import System.Directory+  ( getCurrentDirectory )+import Data.Time+  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )++import Data.List+  ( intersperse )+import Data.Maybe+  ( fromMaybe, isJust )+import Data.Traversable+  ( traverse )+import Control.Monad+  ( when )+#if MIN_VERSION_base(3,0,0)+import Control.Monad+  ( (>=>) )+#endif++import Text.PrettyPrint.HughesPJ hiding (mode, cat)++import Data.Version+  ( Version(..) )+import Distribution.Version+  ( orLaterVersion )++import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..), Category(..) )+import Distribution.Client.Init.Licenses+  ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )+import Distribution.Client.Init.Heuristics+  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )++import Distribution.License+  ( License(..), knownLicenses )+import Distribution.ModuleName+  ( ) -- for the Text instance++import Distribution.ReadE+  ( runReadE, readP_to_E )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Text+  ( display, Text(..) )++initCabal :: InitFlags -> IO ()+initCabal initFlags = do+  hSetBuffering stdout NoBuffering++  initFlags' <- extendFlags initFlags++  writeLicense initFlags'+  writeSetupFile initFlags'+  success <- writeCabalFile initFlags'++  when success $ generateWarnings initFlags'++---------------------------------------------------------------------------+--  Flag acquisition  -----------------------------------------------------+---------------------------------------------------------------------------++-- | Fill in more details by guessing, discovering, or prompting the+--   user.+extendFlags :: InitFlags -> IO InitFlags+extendFlags =  getPackageName+           >=> getVersion+           >=> getLicense+           >=> getAuthorInfo+           >=> getHomepage+           >=> getSynopsis+           >=> getCategory+           >=> getLibOrExec+           >=> getSrcDir+           >=> getModulesAndBuildTools++-- | Combine two actions which may return a value, preferring the first. That+--   is, run the second action only if the first doesn't return a value.+infixr 1 ?>>+(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)+f ?>> g = do+  ma <- f+  if isJust ma+    then return ma+    else g++-- | Witness the isomorphism between Maybe and Flag.+maybeToFlag :: Maybe a -> Flag a+maybeToFlag = maybe NoFlag Flag++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess.+getPackageName :: InitFlags -> IO InitFlags+getPackageName flags = do+  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)+              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)++  pkgName' <-     return (flagToMaybe $ packageName flags)+              ?>> maybePrompt flags (promptStr "Package name" guess)+              ?>> return guess++  return $ flags { packageName = maybeToFlag pkgName' }++-- | Package version: use 0.1 as a last resort, but try prompting the user if+--   possible.+getVersion :: InitFlags -> IO InitFlags+getVersion flags = do+  let v = Just $ Version { versionBranch = [0,1], versionTags = [] }+  v' <-     return (flagToMaybe $ version flags)+        ?>> maybePrompt flags (prompt "Package version" v)+        ?>> return v+  return $ flags { version = maybeToFlag v' }++-- | Choose a license.+getLicense :: InitFlags -> IO InitFlags+getLicense flags = do+  lic <-     return (flagToMaybe $ license flags)+         ?>> fmap (fmap (either UnknownLicense id))+                  (maybePrompt flags+                    (promptList "Please choose a license"+                                knownLicenses (Just BSD3) True))+  return $ flags { license = maybeToFlag lic }++-- | The author's name and email. Prompt, or try to guess from an existing+--   darcs repo.+getAuthorInfo :: InitFlags -> IO InitFlags+getAuthorInfo flags = do+  (authorName, authorEmail)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail+  authorName'  <-     return (flagToMaybe $ author flags)+                  ?>> maybePrompt flags (promptStr "Author name" authorName)+                  ?>> return authorName++  authorEmail' <-     return (flagToMaybe $ email flags)+                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)+                  ?>> return authorEmail++  return $ flags { author = maybeToFlag authorName'+                 , email  = maybeToFlag authorEmail'+                 }++-- | Prompt for a homepage URL.+getHomepage :: InitFlags -> IO InitFlags+getHomepage flags = do+  hp  <- queryHomepage+  hp' <-     return (flagToMaybe $ homepage flags)+         ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp)+         ?>> return hp++  return $ flags { homepage = maybeToFlag hp' }++-- | Right now this does nothing, but it could be changed to do some+--   intelligent guessing.+queryHomepage :: IO (Maybe String)+queryHomepage = return Nothing     -- get default remote darcs repo?++-- | Prompt for a project synopsis.+getSynopsis :: InitFlags -> IO InitFlags+getSynopsis flags = do+  syn <-     return (flagToMaybe $ synopsis flags)+         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)++  return $ flags { synopsis = maybeToFlag syn }++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+getCategory :: InitFlags -> IO InitFlags+getCategory flags = do+  cat <-     return (flagToMaybe $ category flags)+         ?>> maybePrompt flags (promptList "Project category" [Codec ..]+                                                              Nothing True)+  return $ flags { category = maybeToFlag cat }++-- | Ask whether the project builds a library or executable.+getLibOrExec :: InitFlags -> IO InitFlags+getLibOrExec flags = do+  isLib <-     return (flagToMaybe $ packageType flags)+           ?>> maybePrompt flags (either (const Library) id `fmap`+                                   (promptList "What does the package build"+                                               [Library, Executable]+                                               Nothing False))+           ?>> return (Just Library)++  return $ flags { packageType = maybeToFlag isLib }++-- | Try to guess the source root directory (don't prompt the user).+getSrcDir :: InitFlags -> IO InitFlags+getSrcDir flags = do+  srcDirs <-     return (sourceDirs flags)+             ?>> guessSourceDirs++  return $ flags { sourceDirs = srcDirs }++-- XXX+-- | Try to guess source directories.+guessSourceDirs :: IO (Maybe [String])+guessSourceDirs = return Nothing++-- | Get the list of exposed modules and extra tools needed to build them.+getModulesAndBuildTools :: InitFlags -> IO InitFlags+getModulesAndBuildTools flags = do+  dir <- fromMaybe getCurrentDirectory+                   (fmap return . flagToMaybe $ packageDir flags)++  -- XXX really should use guessed source roots.+  sourceFiles <- scanForModules dir++  mods <-      return (exposedModules flags)+           ?>> (return . Just . map moduleName $ sourceFiles)++  tools <-     return (buildTools flags)+           ?>> (return . Just . neededBuildPrograms $ sourceFiles)++  return $ flags { exposedModules = mods+                 , buildTools     = tools }++---------------------------------------------------------------------------+--  Prompting/user interaction  -------------------------------------------+---------------------------------------------------------------------------++-- | Run a prompt or not based on the nonInteractive flag of the+--   InitFlags structure.+maybePrompt :: InitFlags -> IO t -> IO (Maybe t)+maybePrompt flags p =+  case nonInteractive flags of+    Flag True -> return Nothing+    _         -> Just `fmap` p++-- | Create a prompt with optional default value that returns a+--   String.+promptStr :: String -> Maybe String -> IO String+promptStr = promptDefault' Just id++-- | Create a prompt with optional default value that returns a value+--   of some Text instance.+prompt :: Text t => String -> Maybe t -> IO t+prompt = promptDefault'+           (either (const Nothing) Just . runReadE (readP_to_E id parse))+           display++-- | Create a prompt with an optional default value.+promptDefault' :: (String -> Maybe t)       -- ^ parser+               -> (t -> String)             -- ^ pretty-printer+               -> String                    -- ^ prompt message+               -> Maybe t                   -- ^ optional default value+               -> IO t+promptDefault' parser pretty pr def = do+  putStr $ mkDefPrompt pr (pretty `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d)  -> return d+    _  -> case parser inp of+            Just t  -> return t+            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"+                          promptDefault' parser pretty pr def++-- | Create a prompt from a prompt string and a String representation+--   of an optional default value.+mkDefPrompt :: String -> Maybe String -> String+mkDefPrompt pr def = pr ++ defStr def ++ "? "+  where defStr Nothing  = ""+        defStr (Just s) = " [default \"" ++ s ++ "\"]"++-- | Create a prompt from a list of items.+promptList :: (Text t, Eq t)+           => String            -- ^ prompt+           -> [t]               -- ^ choices+           -> Maybe t           -- ^ optional default value+           -> Bool              -- ^ whether to allow an 'other' option+           -> IO (Either String t)+promptList pr choices def other = do+  putStrLn $ pr ++ ":"+  let options1 = map (\c -> (Just c == def, display c)) choices+      options2 = zip ([1..]::[Int])+                     (options1 ++ if other then [(False, "Other (specify)")]+                                           else [])+  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2+  promptList' (length options2) choices def other+ where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest+                      | otherwise = " " ++ star i ++ rest+                  where rest = show n ++ ") "+                        star True = "*"+                        star False = " "++promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' numChoices choices def other = do+  putStr $ mkDefPrompt "Your choice" (display `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d) -> return $ Right d+    _  -> case readMaybe inp of+            Nothing -> invalidChoice inp+            Just n  -> getChoice n+ where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."+                              promptList' numChoices choices def other+       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)+                   | n < numChoices ||+                     (n == numChoices && not other)+                                  = return . Right $ choices !! (n-1)+                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing++readMaybe :: (Read a) => String -> Maybe a+readMaybe s = case reads s of+                [(a,"")] -> Just a+                _        -> Nothing++---------------------------------------------------------------------------+--  File generation  ------------------------------------------------------+---------------------------------------------------------------------------++writeLicense :: InitFlags -> IO ()+writeLicense flags = do+  message flags "Generating LICENSE..."+  year <- getYear+  let licenseFile =+        case license flags of+          Flag BSD3 -> Just $ bsd3 (fromMaybe "???"+                                  . flagToMaybe+                                  . author+                                  $ flags)+                              (show year)++          Flag (GPL (Just (Version {versionBranch = [2]})))+            -> Just gplv2++          Flag (GPL (Just (Version {versionBranch = [3]})))+            -> Just gplv3++          Flag (LGPL (Just (Version {versionBranch = [2]})))+            -> Just lgpl2++          Flag (LGPL (Just (Version {versionBranch = [3]})))+            -> Just lgpl3++          _ -> Nothing++  case licenseFile of+    Just licenseText -> writeFile "LICENSE" licenseText+    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."++getYear :: IO Integer+getYear = do+  u <- getCurrentTime+  z <- getCurrentTimeZone+  let l = utcToLocalTime z u+      (y, _, _) = toGregorian $ localDay l+  return y++writeSetupFile :: InitFlags -> IO ()+writeSetupFile flags = do+  message flags "Generating Setup.hs..."+  writeFile "Setup.hs" setupFile+ where+  setupFile = unlines+    [ "import Distribution.Simple"+    , "main = defaultMain"+    ]++writeCabalFile :: InitFlags -> IO Bool+writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do+  message flags "Error: no package name provided."+  return False+writeCabalFile flags@(InitFlags{packageName = Flag p}) = do+  let cabalFileName = p ++ ".cabal"+  message flags $ "Generating " ++ cabalFileName ++ "..."+  writeFile cabalFileName (generateCabalFile cabalFileName flags)+  return True++-- | Generate a .cabal file from an InitFlags structure.  NOTE: this+--   is rather ad-hoc!  What we would REALLY like is to have a+--   standard low-level AST type representing .cabal files, which+--   preserves things like comments, and to write an *inverse*+--   parser/pretty-printer pair between .cabal files and this AST.+--   Then instead of this ad-hoc code we could just map an InitFlags+--   structure onto a low-level AST structure and use the existing+--   pretty-printing code to generate the file.+generateCabalFile :: String -> InitFlags -> String+generateCabalFile fileName c = render $+  (if (minimal c /= Flag True)+    then showComment (Just $ fileName ++ " auto-generated by cabal init.  For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.")+    else empty)+  $$+  vcat [ fieldS "Name"          (packageName   c)+                (Just "The name of the package.")+                True++       , field  "Version"       (version       c)+                (Just "The package version.  See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")+                True++       , fieldS "Synopsis"      (synopsis      c)+                (Just "A short (one-line) description of the package.")+                True++       , fieldS "Description"   NoFlag+                (Just "A longer description of the package.")+                True++       , fieldS "Homepage"      (homepage     c)+                (Just "URL for the project homepage or repository.")+                False++       , fieldS "Bug-reports"   NoFlag+                (Just "A URL where users can report bugs.")+                False++       , field  "License"       (license      c)+                (Just "The license under which the package is released.")+                True++       , fieldS "License-file" (Flag "LICENSE")+                (Just "The file containing the license text.")+                True++       , fieldS "Author"        (author       c)+                (Just "The package author(s).")+                True++       , fieldS "Maintainer"    (email        c)+                (Just "An email address to which users can send suggestions, bug reports, and patches.")+                True++       , fieldS "Copyright"     NoFlag+                (Just "A copyright notice.")+                True++       , fieldS "Category"      (either id display `fmap` category c)+                Nothing+                True++       , fieldS "Build-type"    (Flag "Simple")+                Nothing+                True++       , fieldS "Extra-source-files" NoFlag+                (Just "Extra files to be distributed with the package, such as examples or a README.")+                True++       , field  "Cabal-version" (Flag $ orLaterVersion (Version [1,2] []))+                (Just "Constraint on the version of Cabal needed to build this package.")+                False++       , case packageType c of+           Flag Executable ->+             text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+             [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True++             , generateBuildInfo c+             ])+           Flag Library    -> text "\nLibrary" $$ (nest 2 $ vcat+             [ fieldS "Exposed-modules" (listField (exposedModules c))+                      (Just "Modules exported by the library.")+                      True++             , generateBuildInfo c+             ])+           _               -> empty+       ]+ where+   generateBuildInfo :: InitFlags -> Doc+   generateBuildInfo c' = vcat+     [ fieldS "Build-depends" (listField (dependencies c'))+              (Just "Packages needed in order to build this package.")+              True++     , fieldS "Other-modules" (listField (otherModules c'))+              (Just "Modules not exported by this package.")+              True++     , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))+              (Just "Directories other than the root containing source files.")+              False++     , fieldS "Build-tools" (listFieldS (buildTools c'))+              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")+              True+     ]++   listField :: Text s => Maybe [s] -> Flag String+   listField = listFieldS . fmap (map display)++   listFieldS :: Maybe [String] -> Flag String+   listFieldS = Flag . maybe "" (concat . intersperse ", ")++   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc+   field s f = fieldS s (fmap display f)++   fieldS :: String        -- ^ Name of the field+          -> Flag String   -- ^ Field contents+          -> Maybe String  -- ^ Comment to explain the field+          -> Bool          -- ^ Should the field be included (commented out) even if blank?+          -> Doc+   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty+   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty+   fieldS s f com _ = case (isJust com, noComments c, minimal c) of+                        (_, _, Flag True) -> id+                        (_, Flag True, _) -> id+                        (True, _, _)      -> (showComment com $$) . ($$ text "")+                        (False, _, _)     -> ($$ text "")+                      $+                      comment f <> text s <> colon+                                <> text (take (20 - length s) (repeat ' '))+                                <> text (fromMaybe "" . flagToMaybe $ f)+   comment NoFlag    = text "-- "+   comment (Flag "") = text "-- "+   comment _         = text ""++   showComment :: Maybe String -> Doc+   showComment (Just t) = vcat . map text+                        . map ("-- "++) . lines+                        . render . fsep . map text . words $ t+   showComment Nothing  = text ""++-- | Generate warnings for missing fields etc.+generateWarnings :: InitFlags -> IO ()+generateWarnings flags = do+  message flags ""+  when (synopsis flags `elem` [NoFlag, Flag ""])+       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")++  message flags "You may want to edit the .cabal file and add a Description field."++-- | Possibly generate a message to stdout, taking into account the+--   --quiet flag.+message :: InitFlags -> String -> IO ()+message (InitFlags{quiet = Flag True}) _ = return ()+message _ s = putStrLn s++#if MIN_VERSION_base(3,0,0)+#else+(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g     = \x -> f x >>= g+#endif
+ Distribution/Client/Init/Heuristics.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Heuristics+-- Copyright   :  (c) Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Heuristics for creating initial cabal files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Heuristics (+    guessPackageName,+    scanForModules,     SourceFileEntry(..),+    neededBuildPrograms,+    guessAuthorNameMail,+    knownCategories,+) where+import Distribution.Simple.Setup(Flag(..))+import Distribution.ModuleName ( ModuleName, fromString )+import Distribution.Client.PackageIndex+    ( allPackagesByName )+import qualified Distribution.PackageDescription as PD+    ( category, packageDescription )+import Distribution.Simple.Utils+         ( intercalate )++import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) )+import Control.Monad (liftM )+import Data.Char   ( isUpper, isLower, isSpace )+#if MIN_VERSION_base(3,0,3)+import Data.Either ( partitionEithers )+#endif+import Data.Maybe  ( catMaybes )+import Data.Monoid ( mempty, mappend )+import qualified Data.Set as Set ( fromList, toList )+import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist,+                          getHomeDirectory, canonicalizePath )+import System.Environment ( getEnvironment )+import System.FilePath ( takeExtension, takeBaseName, dropExtension,+                         (</>), splitDirectories, makeRelative )++-- |Guess the package name based on the given root directory+guessPackageName :: FilePath -> IO String+guessPackageName = liftM (last . splitDirectories) . canonicalizePath++-- |Data type of source files found in the working directory+data SourceFileEntry = SourceFileEntry+    { relativeSourcePath :: FilePath+    , moduleName :: ModuleName+    , fileExtension :: String+    } deriving Show++-- |Search for source files in the given directory+-- and return pairs of guessed haskell source path and+-- module names.+scanForModules :: FilePath -> IO [SourceFileEntry]+scanForModules rootDir = scanForModulesIn rootDir rootDir++scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]+scanForModulesIn projectRoot srcRoot = scan srcRoot []+  where+    scan dir hierarchy = do+        entries <- getDirectoryContents (projectRoot </> dir)+        (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries)+        let modules = catMaybes [ guessModuleName hierarchy file+                                | file <- files+                                , isUpper (head file) ]+        recMods <- mapM (scanRecursive dir hierarchy) dirs+        return $ concat (modules : recMods)+    tagIsDir parent entry = do+        isDir <- doesDirectoryExist (parent </> entry)+        return $ (if isDir then Right else Left) entry+    guessModuleName hierarchy entry+        | takeBaseName entry == "Setup" = Nothing+        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext+        | otherwise = Nothing+      where+        relRoot = makeRelative projectRoot srcRoot+        unqualModName = dropExtension entry+        modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy)+        ext = case takeExtension entry of '.':e -> e; e -> e+    scanRecursive parent hierarchy entry+      | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)+      | isLower (head entry) && not (ignoreDir entry) =+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)+      | otherwise = return []+    ignoreDir ('.':_)  = True+    ignoreDir dir      = dir `elem` ["dist", "_darcs"]++-- Unfortunately we cannot use the version exported by Distribution.Simple.Program+knownSuffixHandlers :: [(String,String)]+knownSuffixHandlers =+  [ ("gc",     "greencard")+  , ("chs",    "chs")+  , ("hsc",    "hsc2hs")+  , ("x",      "alex")+  , ("y",      "happy")+  , ("ly",     "happy")+  , ("cpphs",  "cpp")+  ]++sourceExtensions :: [String]+sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers++neededBuildPrograms :: [SourceFileEntry] -> [String]+neededBuildPrograms entries =+    [ handler+    | ext <- nubSet (map fileExtension entries)+    , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers)+    ]++-- |Guess author and email+guessAuthorNameMail :: IO (Flag String, Flag String)+guessAuthorNameMail =+  update (readFromFile authorRepoFile) mempty >>=+  update (getAuthorHome >>= readFromFile) >>=+  update readFromEnvironment+  where+    update _ info@(Flag _, Flag _) = return info+    update extract info = liftM (`mappend` info) extract -- prefer info+    readFromFile file = do+      exists <- doesFileExist file+      if exists then liftM nameAndMail (readFile file) else return mempty+    readFromEnvironment = fmap extractFromEnvironment getEnvironment+    extractFromEnvironment env =+        let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env)+            emailEnv      = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env)+        in darcsEmailEnv `mappend` emailEnv+    getAuthorHome   = liftM (</> (".darcs" </> "author")) getHomeDirectory+    authorRepoFile  = "_darcs" </> "prefs" </> "author"++-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached+knownCategories :: AvailablePackageDb -> [String]+knownCategories (AvailablePackageDb available _) = nubSet $+    [ cat | pkg <- map head (allPackagesByName available)+          , let catList = (PD.category . PD.packageDescription . packageDescription) pkg+          , cat <- splitString ',' catList+    ]++-- Parse name and email, from darcs pref files or environment variable+nameAndMail :: String -> (Flag String, Flag String)+nameAndMail str+  | all isSpace nameOrEmail = mempty+  | null erest = (mempty, Flag $ trim nameOrEmail)+  | otherwise  = (Flag $ trim nameOrEmail, Flag email)+  where+    (nameOrEmail,erest) = break (== '<') str+    (email,_)           = break (== '>') (tail erest)+    trim                = removeLeadingSpace . reverse . removeLeadingSpace . reverse+    removeLeadingSpace  = dropWhile isSpace++-- split string at given character, and remove whitespaces+splitString :: Char -> String -> [String]+splitString sep str = go str where+    go s = if null s' then [] else tok : go rest where+      s' = dropWhile (\c -> c == sep || isSpace c) s+      (tok,rest) = break (==sep) s'++nubSet :: (Ord a) => [a] -> [a]+nubSet = Set.toList . Set.fromList++{-+test db testProjectRoot = do+  putStrLn "Guessed package name"+  (guessPackageName >=> print) testProjectRoot+  putStrLn "Guessed name and email"+  guessAuthorNameMail >>= print++  mods <- scanForModules testProjectRoot++  putStrLn "Guessed modules"+  mapM_ print mods+  putStrLn "Needed build programs"+  print (neededBuildPrograms mods)++  putStrLn "List of known categories"+  print $ knownCategories db+-}++#if MIN_VERSION_base(3,0,3)+#else+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)+#endif
+ Distribution/Client/Init/Licenses.hs view
@@ -0,0 +1,1722 @@+module Distribution.Client.Init.Licenses+  ( License+  , bsd3+  , gplv2+  , gplv3+  , lgpl2+  , lgpl3++  ) where++type License = String++bsd3 :: String -> String -> License+bsd3 authors year = unlines+    [ "Copyright (c)" ++ year ++ ", " ++ authors+    , ""+    , "All rights reserved."+    , ""+    , "Redistribution and use in source and binary forms, with or without"+    , "modification, are permitted provided that the following conditions are met:"+    , ""+    , "    * Redistributions of source code must retain the above copyright"+    , "      notice, this list of conditions and the following disclaimer."+    , ""+    , "    * Redistributions in binary form must reproduce the above"+    , "      copyright notice, this list of conditions and the following"+    , "      disclaimer in the documentation and/or other materials provided"+    , "      with the distribution."+    , ""+    , "    * Neither the name of " ++ authors ++ " nor the names of other"+    , "      contributors may be used to endorse or promote products derived"+    , "      from this software without specific prior written permission."+    , ""+    , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS"+    , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT"+    , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR"+    , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT"+    , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,"+    , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT"+    , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,"+    , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY"+    , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT"+    , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE"+    , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."+    ]++gplv2 :: License+gplv2 = unlines+    [ "             GNU GENERAL PUBLIC LICENSE"+    , "                Version 2, June 1991"+    , ""+    , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.,"+    , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                     Preamble"+    , ""+    , "  The licenses for most software are designed to take away your"+    , "freedom to share and change it.  By contrast, the GNU General Public"+    , "License is intended to guarantee your freedom to share and change free"+    , "software--to make sure the software is free for all its users.  This"+    , "General Public License applies to most of the Free Software"+    , "Foundation's software and to any other program whose authors commit to"+    , "using it.  (Some other Free Software Foundation software is covered by"+    , "the GNU Lesser General Public License instead.)  You can apply it to"+    , "your programs, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "this service if you wish), that you receive source code or can get it"+    , "if you want it, that you can change the software or use pieces of it"+    , "in new free programs; and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to make restrictions that forbid"+    , "anyone to deny you these rights or to ask you to surrender the rights."+    , "These restrictions translate to certain responsibilities for you if you"+    , "distribute copies of the software, or if you modify it."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must give the recipients all the rights that"+    , "you have.  You must make sure that they, too, receive or can get the"+    , "source code.  And you must show them these terms so they know their"+    , "rights."+    , ""+    , "  We protect your rights with two steps: (1) copyright the software, and"+    , "(2) offer you this license which gives you legal permission to copy,"+    , "distribute and/or modify the software."+    , ""+    , "  Also, for each author's protection and ours, we want to make certain"+    , "that everyone understands that there is no warranty for this free"+    , "software.  If the software is modified by someone else and passed on, we"+    , "want its recipients to know that what they have is not the original, so"+    , "that any problems introduced by others will not reflect on the original"+    , "authors' reputations."+    , ""+    , "  Finally, any free program is threatened constantly by software"+    , "patents.  We wish to avoid the danger that redistributors of a free"+    , "program will individually obtain patent licenses, in effect making the"+    , "program proprietary.  To prevent this, we have made it clear that any"+    , "patent must be licensed for everyone's free use or not licensed at all."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "             GNU GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  0. This License applies to any program or other work which contains"+    , "a notice placed by the copyright holder saying it may be distributed"+    , "under the terms of this General Public License.  The \"Program\", below,"+    , "refers to any such program or work, and a \"work based on the Program\""+    , "means either the Program or any derivative work under copyright law:"+    , "that is to say, a work containing the Program or a portion of it,"+    , "either verbatim or with modifications and/or translated into another"+    , "language.  (Hereinafter, translation is included without limitation in"+    , "the term \"modification\".)  Each licensee is addressed as \"you\"."+    , ""+    , "Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running the Program is not restricted, and the output from the Program"+    , "is covered only if its contents constitute a work based on the"+    , "Program (independent of having been made by running the Program)."+    , "Whether that is true depends on what the Program does."+    , ""+    , "  1. You may copy and distribute verbatim copies of the Program's"+    , "source code as you receive it, in any medium, provided that you"+    , "conspicuously and appropriately publish on each copy an appropriate"+    , "copyright notice and disclaimer of warranty; keep intact all the"+    , "notices that refer to this License and to the absence of any warranty;"+    , "and give any other recipients of the Program a copy of this License"+    , "along with the Program."+    , ""+    , "You may charge a fee for the physical act of transferring a copy, and"+    , "you may at your option offer warranty protection in exchange for a fee."+    , ""+    , "  2. You may modify your copy or copies of the Program or any portion"+    , "of it, thus forming a work based on the Program, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) You must cause the modified files to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    b) You must cause any work that you distribute or publish, that in"+    , "    whole or in part contains or is derived from the Program or any"+    , "    part thereof, to be licensed as a whole at no charge to all third"+    , "    parties under the terms of this License."+    , ""+    , "    c) If the modified program normally reads commands interactively"+    , "    when run, you must cause it, when started running for such"+    , "    interactive use in the most ordinary way, to print or display an"+    , "    announcement including an appropriate copyright notice and a"+    , "    notice that there is no warranty (or else, saying that you provide"+    , "    a warranty) and that users may redistribute the program under"+    , "    these conditions, and telling the user how to view a copy of this"+    , "    License.  (Exception: if the Program itself is interactive but"+    , "    does not normally print such an announcement, your work based on"+    , "    the Program is not required to print an announcement.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Program,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Program, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Program."+    , ""+    , "In addition, mere aggregation of another work not based on the Program"+    , "with the Program (or with a work based on the Program) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may copy and distribute the Program (or a work based on it,"+    , "under Section 2) in object code or executable form under the terms of"+    , "Sections 1 and 2 above provided that you also do one of the following:"+    , ""+    , "    a) Accompany it with the complete corresponding machine-readable"+    , "    source code, which must be distributed under the terms of Sections"+    , "    1 and 2 above on a medium customarily used for software interchange; or,"+    , ""+    , "    b) Accompany it with a written offer, valid for at least three"+    , "    years, to give any third party, for a charge no more than your"+    , "    cost of physically performing source distribution, a complete"+    , "    machine-readable copy of the corresponding source code, to be"+    , "    distributed under the terms of Sections 1 and 2 above on a medium"+    , "    customarily used for software interchange; or,"+    , ""+    , "    c) Accompany it with the information you received as to the offer"+    , "    to distribute corresponding source code.  (This alternative is"+    , "    allowed only for noncommercial distribution and only if you"+    , "    received the program in object code or executable form with such"+    , "    an offer, in accord with Subsection b above.)"+    , ""+    , "The source code for a work means the preferred form of the work for"+    , "making modifications to it.  For an executable work, complete source"+    , "code means all the source code for all modules it contains, plus any"+    , "associated interface definition files, plus the scripts used to"+    , "control compilation and installation of the executable.  However, as a"+    , "special exception, the source code distributed need not include"+    , "anything that is normally distributed (in either source or binary"+    , "form) with the major components (compiler, kernel, and so on) of the"+    , "operating system on which the executable runs, unless that component"+    , "itself accompanies the executable."+    , ""+    , "If distribution of executable or object code is made by offering"+    , "access to copy from a designated place, then offering equivalent"+    , "access to copy the source code from the same place counts as"+    , "distribution of the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  4. You may not copy, modify, sublicense, or distribute the Program"+    , "except as expressly provided under this License.  Any attempt"+    , "otherwise to copy, modify, sublicense or distribute the Program is"+    , "void, and will automatically terminate your rights under this License."+    , "However, parties who have received copies, or rights, from you under"+    , "this License will not have their licenses terminated so long as such"+    , "parties remain in full compliance."+    , ""+    , "  5. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Program or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Program (or any work based on the"+    , "Program), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Program or works based on it."+    , ""+    , "  6. Each time you redistribute the Program (or any work based on the"+    , "Program), the recipient automatically receives a license from the"+    , "original licensor to copy, distribute or modify the Program subject to"+    , "these terms and conditions.  You may not impose any further"+    , "restrictions on the recipients' exercise of the rights granted herein."+    , "You are not responsible for enforcing compliance by third parties to"+    , "this License."+    , ""+    , "  7. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Program at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Program by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Program."+    , ""+    , "If any portion of this section is held invalid or unenforceable under"+    , "any particular circumstance, the balance of the section is intended to"+    , "apply and the section as a whole is intended to apply in other"+    , "circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system, which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  8. If the distribution and/or use of the Program is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Program under this License"+    , "may add an explicit geographical distribution limitation excluding"+    , "those countries, so that distribution is permitted only in or among"+    , "countries not thus excluded.  In such case, this License incorporates"+    , "the limitation as if written in the body of this License."+    , ""+    , "  9. The Free Software Foundation may publish revised and/or new versions"+    , "of the General Public License from time to time.  Such new versions will"+    , "be similar in spirit to the present version, but may differ in detail to"+    , "address new problems or concerns."+    , ""+    , "Each version is given a distinguishing version number.  If the Program"+    , "specifies a version number of this License which applies to it and \"any"+    , "later version\", you have the option of following the terms and conditions"+    , "either of that version or of any later version published by the Free"+    , "Software Foundation.  If the Program does not specify a version number of"+    , "this License, you may choose any version ever published by the Free Software"+    , "Foundation."+    , ""+    , "  10. If you wish to incorporate parts of the Program into other free"+    , "programs whose distribution conditions are different, write to the author"+    , "to ask for permission.  For software which is copyrighted by the Free"+    , "Software Foundation, write to the Free Software Foundation; we sometimes"+    , "make exceptions for this.  Our decision will be guided by the two goals"+    , "of preserving the free status of all derivatives of our free software and"+    , "of promoting the sharing and reuse of software generally."+    , ""+    , "                     NO WARRANTY"+    , ""+    , "  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"+    , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN"+    , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"+    , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"+    , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"+    , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS"+    , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE"+    , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"+    , "REPAIR OR CORRECTION."+    , ""+    , "  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"+    , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"+    , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"+    , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"+    , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"+    , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"+    , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"+    , "POSSIBILITY OF SUCH DAMAGES."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program 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."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "If the program is interactive, make it output a short notice like this"+    , "when it starts in an interactive mode:"+    , ""+    , "    Gnomovision version 69, Copyright (C) year name of author"+    , "    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, the commands you use may"+    , "be called something other than `show w' and `show c'; they could even be"+    , "mouse-clicks or menu items--whatever suits your program."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the program, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the program"+    , "  `Gnomovision' (which makes passes at compilers) written by James Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1989"+    , "  Ty Coon, President of Vice"+    , ""+    , "This General Public License does not permit incorporating your program into"+    , "proprietary programs.  If your program is a subroutine library, you may"+    , "consider it more useful to permit linking proprietary applications with the"+    , "library.  If this is what you want to do, use the GNU Lesser General"+    , "Public License instead of this License."+    ]++gplv3 :: License+gplv3 = unlines+    [ "              GNU GENERAL PUBLIC LICENSE"+    , "                Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                     Preamble"+    , ""+    , "  The GNU General Public License is a free, copyleft license for"+    , "software and other kinds of works."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "the GNU General Public License is intended to guarantee your freedom to"+    , "share and change all versions of a program--to make sure it remains free"+    , "software for all its users.  We, the Free Software Foundation, use the"+    , "GNU General Public License for most of our software; it applies also to"+    , "any other work released this way by its authors.  You can apply it to"+    , "your programs, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "them if you wish), that you receive source code or can get it if you"+    , "want it, that you can change the software or use pieces of it in new"+    , "free programs, and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to prevent others from denying you"+    , "these rights or asking you to surrender the rights.  Therefore, you have"+    , "certain responsibilities if you distribute copies of the software, or if"+    , "you modify it: responsibilities to respect the freedom of others."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must pass on to the recipients the same"+    , "freedoms that you received.  You must make sure that they, too, receive"+    , "or can get the source code.  And you must show them these terms so they"+    , "know their rights."+    , ""+    , "  Developers that use the GNU GPL protect your rights with two steps:"+    , "(1) assert copyright on the software, and (2) offer you this License"+    , "giving you legal permission to copy, distribute and/or modify it."+    , ""+    , "  For the developers' and authors' protection, the GPL clearly explains"+    , "that there is no warranty for this free software.  For both users' and"+    , "authors' sake, the GPL requires that modified versions be marked as"+    , "changed, so that their problems will not be attributed erroneously to"+    , "authors of previous versions."+    , ""+    , "  Some devices are designed to deny users access to install or run"+    , "modified versions of the software inside them, although the manufacturer"+    , "can do so.  This is fundamentally incompatible with the aim of"+    , "protecting users' freedom to change the software.  The systematic"+    , "pattern of such abuse occurs in the area of products for individuals to"+    , "use, which is precisely where it is most unacceptable.  Therefore, we"+    , "have designed this version of the GPL to prohibit the practice for those"+    , "products.  If such problems arise substantially in other domains, we"+    , "stand ready to extend this provision to those domains in future versions"+    , "of the GPL, as needed to protect the freedom of users."+    , ""+    , "  Finally, every program is threatened constantly by software patents."+    , "States should not allow patents to restrict development and use of"+    , "software on general-purpose computers, but in those that do, we wish to"+    , "avoid the special danger that patents applied to a free program could"+    , "make it effectively proprietary.  To prevent this, the GPL assures that"+    , "patents cannot be used to render the program non-free."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "                TERMS AND CONDITIONS"+    , ""+    , "  0. Definitions."+    , ""+    , "  \"This License\" refers to version 3 of the GNU General Public License."+    , ""+    , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"+    , "works, such as semiconductor masks."+    , " "+    , "  \"The Program\" refers to any copyrightable work licensed under this"+    , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"+    , "\"recipients\" may be individuals or organizations."+    , ""+    , "  To \"modify\" a work means to copy from or adapt all or part of the work"+    , "in a fashion requiring copyright permission, other than the making of an"+    , "exact copy.  The resulting work is called a \"modified version\" of the"+    , "earlier work or a work \"based on\" the earlier work."+    , ""+    , "  A \"covered work\" means either the unmodified Program or a work based"+    , "on the Program."+    , ""+    , "  To \"propagate\" a work means to do anything with it that, without"+    , "permission, would make you directly or secondarily liable for"+    , "infringement under applicable copyright law, except executing it on a"+    , "computer or modifying a private copy.  Propagation includes copying,"+    , "distribution (with or without modification), making available to the"+    , "public, and in some countries other activities as well."+    , ""+    , "  To \"convey\" a work means any kind of propagation that enables other"+    , "parties to make or receive copies.  Mere interaction with a user through"+    , "a computer network, with no transfer of a copy, is not conveying."+    , ""+    , "  An interactive user interface displays \"Appropriate Legal Notices\""+    , "to the extent that it includes a convenient and prominently visible"+    , "feature that (1) displays an appropriate copyright notice, and (2)"+    , "tells the user that there is no warranty for the work (except to the"+    , "extent that warranties are provided), that licensees may convey the"+    , "work under this License, and how to view a copy of this License.  If"+    , "the interface presents a list of user commands or options, such as a"+    , "menu, a prominent item in the list meets this criterion."+    , ""+    , "  1. Source Code."+    , ""+    , "  The \"source code\" for a work means the preferred form of the work"+    , "for making modifications to it.  \"Object code\" means any non-source"+    , "form of a work."+    , ""+    , "  A \"Standard Interface\" means an interface that either is an official"+    , "standard defined by a recognized standards body, or, in the case of"+    , "interfaces specified for a particular programming language, one that"+    , "is widely used among developers working in that language."+    , ""+    , "  The \"System Libraries\" of an executable work include anything, other"+    , "than the work as a whole, that (a) is included in the normal form of"+    , "packaging a Major Component, but which is not part of that Major"+    , "Component, and (b) serves only to enable use of the work with that"+    , "Major Component, or to implement a Standard Interface for which an"+    , "implementation is available to the public in source code form.  A"+    , "\"Major Component\", in this context, means a major essential component"+    , "(kernel, window system, and so on) of the specific operating system"+    , "(if any) on which the executable work runs, or a compiler used to"+    , "produce the work, or an object code interpreter used to run it."+    , ""+    , "  The \"Corresponding Source\" for a work in object code form means all"+    , "the source code needed to generate, install, and (for an executable"+    , "work) run the object code and to modify the work, including scripts to"+    , "control those activities.  However, it does not include the work's"+    , "System Libraries, or general-purpose tools or generally available free"+    , "programs which are used unmodified in performing those activities but"+    , "which are not part of the work.  For example, Corresponding Source"+    , "includes interface definition files associated with source files for"+    , "the work, and the source code for shared libraries and dynamically"+    , "linked subprograms that the work is specifically designed to require,"+    , "such as by intimate data communication or control flow between those"+    , "subprograms and other parts of the work."+    , ""+    , "  The Corresponding Source need not include anything that users"+    , "can regenerate automatically from other parts of the Corresponding"+    , "Source."+    , ""+    , "  The Corresponding Source for a work in source code form is that"+    , "same work."+    , ""+    , "  2. Basic Permissions."+    , ""+    , "  All rights granted under this License are granted for the term of"+    , "copyright on the Program, and are irrevocable provided the stated"+    , "conditions are met.  This License explicitly affirms your unlimited"+    , "permission to run the unmodified Program.  The output from running a"+    , "covered work is covered by this License only if the output, given its"+    , "content, constitutes a covered work.  This License acknowledges your"+    , "rights of fair use or other equivalent, as provided by copyright law."+    , ""+    , "  You may make, run and propagate covered works that you do not"+    , "convey, without conditions so long as your license otherwise remains"+    , "in force.  You may convey covered works to others for the sole purpose"+    , "of having them make modifications exclusively for you, or provide you"+    , "with facilities for running those works, provided that you comply with"+    , "the terms of this License in conveying all material for which you do"+    , "not control copyright.  Those thus making or running the covered works"+    , "for you must do so exclusively on your behalf, under your direction"+    , "and control, on terms that prohibit them from making any copies of"+    , "your copyrighted material outside their relationship with you."+    , ""+    , "  Conveying under any other circumstances is permitted solely under"+    , "the conditions stated below.  Sublicensing is not allowed; section 10"+    , "makes it unnecessary."+    , ""+    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."+    , ""+    , "  No covered work shall be deemed part of an effective technological"+    , "measure under any applicable law fulfilling obligations under article"+    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"+    , "similar laws prohibiting or restricting circumvention of such"+    , "measures."+    , ""+    , "  When you convey a covered work, you waive any legal power to forbid"+    , "circumvention of technological measures to the extent such circumvention"+    , "is effected by exercising rights under this License with respect to"+    , "the covered work, and you disclaim any intention to limit operation or"+    , "modification of the work as a means of enforcing, against the work's"+    , "users, your or third parties' legal rights to forbid circumvention of"+    , "technological measures."+    , ""+    , "  4. Conveying Verbatim Copies."+    , ""+    , "  You may convey verbatim copies of the Program's source code as you"+    , "receive it, in any medium, provided that you conspicuously and"+    , "appropriately publish on each copy an appropriate copyright notice;"+    , "keep intact all notices stating that this License and any"+    , "non-permissive terms added in accord with section 7 apply to the code;"+    , "keep intact all notices of the absence of any warranty; and give all"+    , "recipients a copy of this License along with the Program."+    , ""+    , "  You may charge any price or no price for each copy that you convey,"+    , "and you may offer support or warranty protection for a fee."+    , ""+    , "  5. Conveying Modified Source Versions."+    , ""+    , "  You may convey a work based on the Program, or the modifications to"+    , "produce it from the Program, in the form of source code under the"+    , "terms of section 4, provided that you also meet all of these conditions:"+    , ""+    , "    a) The work must carry prominent notices stating that you modified"+    , "    it, and giving a relevant date."+    , ""+    , "    b) The work must carry prominent notices stating that it is"+    , "    released under this License and any conditions added under section"+    , "    7.  This requirement modifies the requirement in section 4 to"+    , "    \"keep intact all notices\"."+    , ""+    , "    c) You must license the entire work, as a whole, under this"+    , "    License to anyone who comes into possession of a copy.  This"+    , "    License will therefore apply, along with any applicable section 7"+    , "    additional terms, to the whole of the work, and all its parts,"+    , "    regardless of how they are packaged.  This License gives no"+    , "    permission to license the work in any other way, but it does not"+    , "    invalidate such permission if you have separately received it."+    , ""+    , "    d) If the work has interactive user interfaces, each must display"+    , "    Appropriate Legal Notices; however, if the Program has interactive"+    , "    interfaces that do not display Appropriate Legal Notices, your"+    , "    work need not make them do so."+    , ""+    , "  A compilation of a covered work with other separate and independent"+    , "works, which are not by their nature extensions of the covered work,"+    , "and which are not combined with it such as to form a larger program,"+    , "in or on a volume of a storage or distribution medium, is called an"+    , "\"aggregate\" if the compilation and its resulting copyright are not"+    , "used to limit the access or legal rights of the compilation's users"+    , "beyond what the individual works permit.  Inclusion of a covered work"+    , "in an aggregate does not cause this License to apply to the other"+    , "parts of the aggregate."+    , ""+    , "  6. Conveying Non-Source Forms."+    , ""+    , "  You may convey a covered work in object code form under the terms"+    , "of sections 4 and 5, provided that you also convey the"+    , "machine-readable Corresponding Source under the terms of this License,"+    , "in one of these ways:"+    , ""+    , "    a) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by the"+    , "    Corresponding Source fixed on a durable physical medium"+    , "    customarily used for software interchange."+    , ""+    , "    b) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by a"+    , "    written offer, valid for at least three years and valid for as"+    , "    long as you offer spare parts or customer support for that product"+    , "    model, to give anyone who possesses the object code either (1) a"+    , "    copy of the Corresponding Source for all the software in the"+    , "    product that is covered by this License, on a durable physical"+    , "    medium customarily used for software interchange, for a price no"+    , "    more than your reasonable cost of physically performing this"+    , "    conveying of source, or (2) access to copy the"+    , "    Corresponding Source from a network server at no charge."+    , ""+    , "    c) Convey individual copies of the object code with a copy of the"+    , "    written offer to provide the Corresponding Source.  This"+    , "    alternative is allowed only occasionally and noncommercially, and"+    , "    only if you received the object code with such an offer, in accord"+    , "    with subsection 6b."+    , ""+    , "    d) Convey the object code by offering access from a designated"+    , "    place (gratis or for a charge), and offer equivalent access to the"+    , "    Corresponding Source in the same way through the same place at no"+    , "    further charge.  You need not require recipients to copy the"+    , "    Corresponding Source along with the object code.  If the place to"+    , "    copy the object code is a network server, the Corresponding Source"+    , "    may be on a different server (operated by you or a third party)"+    , "    that supports equivalent copying facilities, provided you maintain"+    , "    clear directions next to the object code saying where to find the"+    , "    Corresponding Source.  Regardless of what server hosts the"+    , "    Corresponding Source, you remain obligated to ensure that it is"+    , "    available for as long as needed to satisfy these requirements."+    , ""+    , "    e) Convey the object code using peer-to-peer transmission, provided"+    , "    you inform other peers where the object code and Corresponding"+    , "    Source of the work are being offered to the general public at no"+    , "    charge under subsection 6d."+    , ""+    , "  A separable portion of the object code, whose source code is excluded"+    , "from the Corresponding Source as a System Library, need not be"+    , "included in conveying the object code work."+    , ""+    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"+    , "tangible personal property which is normally used for personal, family,"+    , "or household purposes, or (2) anything designed or sold for incorporation"+    , "into a dwelling.  In determining whether a product is a consumer product,"+    , "doubtful cases shall be resolved in favor of coverage.  For a particular"+    , "product received by a particular user, \"normally used\" refers to a"+    , "typical or common use of that class of product, regardless of the status"+    , "of the particular user or of the way in which the particular user"+    , "actually uses, or expects or is expected to use, the product.  A product"+    , "is a consumer product regardless of whether the product has substantial"+    , "commercial, industrial or non-consumer uses, unless such uses represent"+    , "the only significant mode of use of the product."+    , ""+    , "  \"Installation Information\" for a User Product means any methods,"+    , "procedures, authorization keys, or other information required to install"+    , "and execute modified versions of a covered work in that User Product from"+    , "a modified version of its Corresponding Source.  The information must"+    , "suffice to ensure that the continued functioning of the modified object"+    , "code is in no case prevented or interfered with solely because"+    , "modification has been made."+    , ""+    , "  If you convey an object code work under this section in, or with, or"+    , "specifically for use in, a User Product, and the conveying occurs as"+    , "part of a transaction in which the right of possession and use of the"+    , "User Product is transferred to the recipient in perpetuity or for a"+    , "fixed term (regardless of how the transaction is characterized), the"+    , "Corresponding Source conveyed under this section must be accompanied"+    , "by the Installation Information.  But this requirement does not apply"+    , "if neither you nor any third party retains the ability to install"+    , "modified object code on the User Product (for example, the work has"+    , "been installed in ROM)."+    , ""+    , "  The requirement to provide Installation Information does not include a"+    , "requirement to continue to provide support service, warranty, or updates"+    , "for a work that has been modified or installed by the recipient, or for"+    , "the User Product in which it has been modified or installed.  Access to a"+    , "network may be denied when the modification itself materially and"+    , "adversely affects the operation of the network or violates the rules and"+    , "protocols for communication across the network."+    , ""+    , "  Corresponding Source conveyed, and Installation Information provided,"+    , "in accord with this section must be in a format that is publicly"+    , "documented (and with an implementation available to the public in"+    , "source code form), and must require no special password or key for"+    , "unpacking, reading or copying."+    , ""+    , "  7. Additional Terms."+    , ""+    , "  \"Additional permissions\" are terms that supplement the terms of this"+    , "License by making exceptions from one or more of its conditions."+    , "Additional permissions that are applicable to the entire Program shall"+    , "be treated as though they were included in this License, to the extent"+    , "that they are valid under applicable law.  If additional permissions"+    , "apply only to part of the Program, that part may be used separately"+    , "under those permissions, but the entire Program remains governed by"+    , "this License without regard to the additional permissions."+    , ""+    , "  When you convey a copy of a covered work, you may at your option"+    , "remove any additional permissions from that copy, or from any part of"+    , "it.  (Additional permissions may be written to require their own"+    , "removal in certain cases when you modify the work.)  You may place"+    , "additional permissions on material, added by you to a covered work,"+    , "for which you have or can give appropriate copyright permission."+    , ""+    , "  Notwithstanding any other provision of this License, for material you"+    , "add to a covered work, you may (if authorized by the copyright holders of"+    , "that material) supplement the terms of this License with terms:"+    , ""+    , "    a) Disclaiming warranty or limiting liability differently from the"+    , "    terms of sections 15 and 16 of this License; or"+    , ""+    , "    b) Requiring preservation of specified reasonable legal notices or"+    , "    author attributions in that material or in the Appropriate Legal"+    , "    Notices displayed by works containing it; or"+    , ""+    , "    c) Prohibiting misrepresentation of the origin of that material, or"+    , "    requiring that modified versions of such material be marked in"+    , "    reasonable ways as different from the original version; or"+    , ""+    , "    d) Limiting the use for publicity purposes of names of licensors or"+    , "    authors of the material; or"+    , ""+    , "    e) Declining to grant rights under trademark law for use of some"+    , "    trade names, trademarks, or service marks; or"+    , ""+    , "    f) Requiring indemnification of licensors and authors of that"+    , "    material by anyone who conveys the material (or modified versions of"+    , "    it) with contractual assumptions of liability to the recipient, for"+    , "    any liability that these contractual assumptions directly impose on"+    , "    those licensors and authors."+    , ""+    , "  All other non-permissive additional terms are considered \"further"+    , "restrictions\" within the meaning of section 10.  If the Program as you"+    , "received it, or any part of it, contains a notice stating that it is"+    , "governed by this License along with a term that is a further"+    , "restriction, you may remove that term.  If a license document contains"+    , "a further restriction but permits relicensing or conveying under this"+    , "License, you may add to a covered work material governed by the terms"+    , "of that license document, provided that the further restriction does"+    , "not survive such relicensing or conveying."+    , ""+    , "  If you add terms to a covered work in accord with this section, you"+    , "must place, in the relevant source files, a statement of the"+    , "additional terms that apply to those files, or a notice indicating"+    , "where to find the applicable terms."+    , ""+    , "  Additional terms, permissive or non-permissive, may be stated in the"+    , "form of a separately written license, or stated as exceptions;"+    , "the above requirements apply either way."+    , ""+    , "  8. Termination."+    , ""+    , "  You may not propagate or modify a covered work except as expressly"+    , "provided under this License.  Any attempt otherwise to propagate or"+    , "modify it is void, and will automatically terminate your rights under"+    , "this License (including any patent licenses granted under the third"+    , "paragraph of section 11)."+    , ""+    , "  However, if you cease all violation of this License, then your"+    , "license from a particular copyright holder is reinstated (a)"+    , "provisionally, unless and until the copyright holder explicitly and"+    , "finally terminates your license, and (b) permanently, if the copyright"+    , "holder fails to notify you of the violation by some reasonable means"+    , "prior to 60 days after the cessation."+    , ""+    , "  Moreover, your license from a particular copyright holder is"+    , "reinstated permanently if the copyright holder notifies you of the"+    , "violation by some reasonable means, this is the first time you have"+    , "received notice of violation of this License (for any work) from that"+    , "copyright holder, and you cure the violation prior to 30 days after"+    , "your receipt of the notice."+    , ""+    , "  Termination of your rights under this section does not terminate the"+    , "licenses of parties who have received copies or rights from you under"+    , "this License.  If your rights have been terminated and not permanently"+    , "reinstated, you do not qualify to receive new licenses for the same"+    , "material under section 10."+    , ""+    , "  9. Acceptance Not Required for Having Copies."+    , ""+    , "  You are not required to accept this License in order to receive or"+    , "run a copy of the Program.  Ancillary propagation of a covered work"+    , "occurring solely as a consequence of using peer-to-peer transmission"+    , "to receive a copy likewise does not require acceptance.  However,"+    , "nothing other than this License grants you permission to propagate or"+    , "modify any covered work.  These actions infringe copyright if you do"+    , "not accept this License.  Therefore, by modifying or propagating a"+    , "covered work, you indicate your acceptance of this License to do so."+    , ""+    , "  10. Automatic Licensing of Downstream Recipients."+    , ""+    , "  Each time you convey a covered work, the recipient automatically"+    , "receives a license from the original licensors, to run, modify and"+    , "propagate that work, subject to this License.  You are not responsible"+    , "for enforcing compliance by third parties with this License."+    , ""+    , "  An \"entity transaction\" is a transaction transferring control of an"+    , "organization, or substantially all assets of one, or subdividing an"+    , "organization, or merging organizations.  If propagation of a covered"+    , "work results from an entity transaction, each party to that"+    , "transaction who receives a copy of the work also receives whatever"+    , "licenses to the work the party's predecessor in interest had or could"+    , "give under the previous paragraph, plus a right to possession of the"+    , "Corresponding Source of the work from the predecessor in interest, if"+    , "the predecessor has it or can get it with reasonable efforts."+    , ""+    , "  You may not impose any further restrictions on the exercise of the"+    , "rights granted or affirmed under this License.  For example, you may"+    , "not impose a license fee, royalty, or other charge for exercise of"+    , "rights granted under this License, and you may not initiate litigation"+    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"+    , "any patent claim is infringed by making, using, selling, offering for"+    , "sale, or importing the Program or any portion of it."+    , ""+    , "  11. Patents."+    , ""+    , "  A \"contributor\" is a copyright holder who authorizes use under this"+    , "License of the Program or a work on which the Program is based.  The"+    , "work thus licensed is called the contributor's \"contributor version\"."+    , ""+    , "  A contributor's \"essential patent claims\" are all patent claims"+    , "owned or controlled by the contributor, whether already acquired or"+    , "hereafter acquired, that would be infringed by some manner, permitted"+    , "by this License, of making, using, or selling its contributor version,"+    , "but do not include claims that would be infringed only as a"+    , "consequence of further modification of the contributor version.  For"+    , "purposes of this definition, \"control\" includes the right to grant"+    , "patent sublicenses in a manner consistent with the requirements of"+    , "this License."+    , ""+    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"+    , "patent license under the contributor's essential patent claims, to"+    , "make, use, sell, offer for sale, import and otherwise run, modify and"+    , "propagate the contents of its contributor version."+    , ""+    , "  In the following three paragraphs, a \"patent license\" is any express"+    , "agreement or commitment, however denominated, not to enforce a patent"+    , "(such as an express permission to practice a patent or covenant not to"+    , "sue for patent infringement).  To \"grant\" such a patent license to a"+    , "party means to make such an agreement or commitment not to enforce a"+    , "patent against the party."+    , ""+    , "  If you convey a covered work, knowingly relying on a patent license,"+    , "and the Corresponding Source of the work is not available for anyone"+    , "to copy, free of charge and under the terms of this License, through a"+    , "publicly available network server or other readily accessible means,"+    , "then you must either (1) cause the Corresponding Source to be so"+    , "available, or (2) arrange to deprive yourself of the benefit of the"+    , "patent license for this particular work, or (3) arrange, in a manner"+    , "consistent with the requirements of this License, to extend the patent"+    , "license to downstream recipients.  \"Knowingly relying\" means you have"+    , "actual knowledge that, but for the patent license, your conveying the"+    , "covered work in a country, or your recipient's use of the covered work"+    , "in a country, would infringe one or more identifiable patents in that"+    , "country that you have reason to believe are valid."+    , "  "+    , "  If, pursuant to or in connection with a single transaction or"+    , "arrangement, you convey, or propagate by procuring conveyance of, a"+    , "covered work, and grant a patent license to some of the parties"+    , "receiving the covered work authorizing them to use, propagate, modify"+    , "or convey a specific copy of the covered work, then the patent license"+    , "you grant is automatically extended to all recipients of the covered"+    , "work and works based on it."+    , ""+    , "  A patent license is \"discriminatory\" if it does not include within"+    , "the scope of its coverage, prohibits the exercise of, or is"+    , "conditioned on the non-exercise of one or more of the rights that are"+    , "specifically granted under this License.  You may not convey a covered"+    , "work if you are a party to an arrangement with a third party that is"+    , "in the business of distributing software, under which you make payment"+    , "to the third party based on the extent of your activity of conveying"+    , "the work, and under which the third party grants, to any of the"+    , "parties who would receive the covered work from you, a discriminatory"+    , "patent license (a) in connection with copies of the covered work"+    , "conveyed by you (or copies made from those copies), or (b) primarily"+    , "for and in connection with specific products or compilations that"+    , "contain the covered work, unless you entered into that arrangement,"+    , "or that patent license was granted, prior to 28 March 2007."+    , ""+    , "  Nothing in this License shall be construed as excluding or limiting"+    , "any implied license or other defenses to infringement that may"+    , "otherwise be available to you under applicable patent law."+    , ""+    , "  12. No Surrender of Others' Freedom."+    , ""+    , "  If conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot convey a"+    , "covered work so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you may"+    , "not convey it at all.  For example, if you agree to terms that obligate you"+    , "to collect a royalty for further conveying from those to whom you convey"+    , "the Program, the only way you could satisfy both those terms and this"+    , "License would be to refrain entirely from conveying the Program."+    , ""+    , "  13. Use with the GNU Affero General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, you have"+    , "permission to link or combine any covered work with a work licensed"+    , "under version 3 of the GNU Affero General Public License into a single"+    , "combined work, and to convey the resulting work.  The terms of this"+    , "License will continue to apply to the part which is the covered work,"+    , "but the special requirements of the GNU Affero General Public License,"+    , "section 13, concerning interaction through a network will apply to the"+    , "combination as such."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU General Public License from time to time.  Such new versions will"+    , "be similar in spirit to the present version, but may differ in detail to"+    , "address new problems or concerns."+    , ""+    , "  Each version is given a distinguishing version number.  If the"+    , "Program specifies that a certain numbered version of the GNU General"+    , "Public License \"or any later version\" applies to it, you have the"+    , "option of following the terms and conditions either of that numbered"+    , "version or of any later version published by the Free Software"+    , "Foundation.  If the Program does not specify a version number of the"+    , "GNU General Public License, you may choose any version ever published"+    , "by the Free Software Foundation."+    , ""+    , "  If the Program specifies that a proxy can decide which future"+    , "versions of the GNU General Public License can be used, that proxy's"+    , "public statement of acceptance of a version permanently authorizes you"+    , "to choose that version for the Program."+    , ""+    , "  Later license versions may give you additional or different"+    , "permissions.  However, no additional obligations are imposed on any"+    , "author or copyright holder as a result of your choosing to follow a"+    , "later version."+    , ""+    , "  15. Disclaimer of Warranty."+    , ""+    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"+    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"+    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"+    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"+    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"+    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"+    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. Limitation of Liability."+    , ""+    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"+    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"+    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"+    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"+    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"+    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"+    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"+    , "SUCH DAMAGES."+    , ""+    , "  17. Interpretation of Sections 15 and 16."+    , ""+    , "  If the disclaimer of warranty and limitation of liability provided"+    , "above cannot be given local legal effect according to their terms,"+    , "reviewing courts shall apply local law that most closely approximates"+    , "an absolute waiver of all civil liability in connection with the"+    , "Program, unless a warranty or assumption of liability accompanies a"+    , "copy of the Program in return for a fee."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "state the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software: you can redistribute it and/or modify"+    , "    it under the terms of the GNU General Public License as published by"+    , "    the Free Software Foundation, either version 3 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program is distributed in the hope that it will be useful,"+    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "    GNU General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU General Public License"+    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "  If the program does terminal interaction, make it output a short"+    , "notice like this when it starts in an interactive mode:"+    , ""+    , "    <program>  Copyright (C) <year>  <name of author>"+    , "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, your program's commands"+    , "might be different; for a GUI interface, you would use an \"about box\"."+    , ""+    , "  You should also get your employer (if you work as a programmer) or school,"+    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."+    , "For more information on this, and how to apply and follow the GNU GPL, see"+    , "<http://www.gnu.org/licenses/>."+    , ""+    , "  The GNU General Public License does not permit incorporating your program"+    , "into proprietary programs.  If your program is a subroutine library, you"+    , "may consider it more useful to permit linking proprietary applications with"+    , "the library.  If this is what you want to do, use the GNU Lesser General"+    , "Public License instead of this License.  But first, please read"+    , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."+    , ""+    ]++lgpl2 :: License+lgpl2 = unlines+    [ "           GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "                 Version 2, June 1991"+    , ""+    , " Copyright (C) 1991 Free Software Foundation, Inc."+    , " 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "[This is the first released version of the library GPL.  It is"+    , " numbered 2 because it goes with version 2 of the ordinary GPL.]"+    , ""+    , "                     Preamble"+    , ""+    , "  The licenses for most software are designed to take away your"+    , "freedom to share and change it.  By contrast, the GNU General Public"+    , "Licenses are intended to guarantee your freedom to share and change"+    , "free software--to make sure the software is free for all its users."+    , ""+    , "  This license, the Library General Public License, applies to some"+    , "specially designated Free Software Foundation software, and to any"+    , "other libraries whose authors decide to use it.  You can use it for"+    , "your libraries, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "this service if you wish), that you receive source code or can get it"+    , "if you want it, that you can change the software or use pieces of it"+    , "in new free programs; and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to make restrictions that forbid"+    , "anyone to deny you these rights or to ask you to surrender the rights."+    , "These restrictions translate to certain responsibilities for you if"+    , "you distribute copies of the library, or if you modify it."+    , ""+    , "  For example, if you distribute copies of the library, whether gratis"+    , "or for a fee, you must give the recipients all the rights that we gave"+    , "you.  You must make sure that they, too, receive or can get the source"+    , "code.  If you link a program with the library, you must provide"+    , "complete object files to the recipients so that they can relink them"+    , "with the library, after making changes to the library and recompiling"+    , "it.  And you must show them these terms so they know their rights."+    , ""+    , "  Our method of protecting your rights has two steps: (1) copyright"+    , "the library, and (2) offer you this license which gives you legal"+    , "permission to copy, distribute and/or modify the library."+    , ""+    , "  Also, for each distributor's protection, we want to make certain"+    , "that everyone understands that there is no warranty for this free"+    , "library.  If the library is modified by someone else and passed on, we"+    , "want its recipients to know that what they have is not the original"+    , "version, so that any problems introduced by others will not reflect on"+    , "the original authors' reputations."+    , ""+    , "  Finally, any free program is threatened constantly by software"+    , "patents.  We wish to avoid the danger that companies distributing free"+    , "software will individually obtain patent licenses, thus in effect"+    , "transforming the program into proprietary software.  To prevent this,"+    , "we have made it clear that any patent must be licensed for everyone's"+    , "free use or not licensed at all."+    , ""+    , "  Most GNU software, including some libraries, is covered by the ordinary"+    , "GNU General Public License, which was designed for utility programs.  This"+    , "license, the GNU Library General Public License, applies to certain"+    , "designated libraries.  This license is quite different from the ordinary"+    , "one; be sure to read it in full, and don't assume that anything in it is"+    , "the same as in the ordinary license."+    , ""+    , "  The reason we have a separate public license for some libraries is that"+    , "they blur the distinction we usually make between modifying or adding to a"+    , "program and simply using it.  Linking a program with a library, without"+    , "changing the library, is in some sense simply using the library, and is"+    , "analogous to running a utility program or application program.  However, in"+    , "a textual and legal sense, the linked executable is a combined work, a"+    , "derivative of the original library, and the ordinary General Public License"+    , "treats it as such."+    , ""+    , "  Because of this blurred distinction, using the ordinary General"+    , "Public License for libraries did not effectively promote software"+    , "sharing, because most developers did not use the libraries.  We"+    , "concluded that weaker conditions might promote sharing better."+    , ""+    , "  However, unrestricted linking of non-free programs would deprive the"+    , "users of those programs of all benefit from the free status of the"+    , "libraries themselves.  This Library General Public License is intended to"+    , "permit developers of non-free programs to use free libraries, while"+    , "preserving your freedom as a user of such programs to change the free"+    , "libraries that are incorporated in them.  (We have not seen how to achieve"+    , "this as regards changes in header files, but we have achieved it as regards"+    , "changes in the actual functions of the Library.)  The hope is that this"+    , "will lead to faster development of free libraries."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow.  Pay close attention to the difference between a"+    , "\"work based on the library\" and a \"work that uses the library\".  The"+    , "former contains code derived from the library, while the latter only"+    , "works together with the library."+    , ""+    , "  Note that it is possible for a library to be covered by the ordinary"+    , "General Public License rather than by this special one."+    , ""+    , "              GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  0. This License Agreement applies to any software library which"+    , "contains a notice placed by the copyright holder or other authorized"+    , "party saying it may be distributed under the terms of this Library"+    , "General Public License (also called \"this License\").  Each licensee is"+    , "addressed as \"you\"."+    , ""+    , "  A \"library\" means a collection of software functions and/or data"+    , "prepared so as to be conveniently linked with application programs"+    , "(which use some of those functions and data) to form executables."+    , ""+    , "  The \"Library\", below, refers to any such software library or work"+    , "which has been distributed under these terms.  A \"work based on the"+    , "Library\" means either the Library or any derivative work under"+    , "copyright law: that is to say, a work containing the Library or a"+    , "portion of it, either verbatim or with modifications and/or translated"+    , "straightforwardly into another language.  (Hereinafter, translation is"+    , "included without limitation in the term \"modification\".)"+    , ""+    , "  \"Source code\" for a work means the preferred form of the work for"+    , "making modifications to it.  For a library, complete source code means"+    , "all the source code for all modules it contains, plus any associated"+    , "interface definition files, plus the scripts used to control compilation"+    , "and installation of the library."+    , ""+    , "  Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running a program using the Library is not restricted, and output from"+    , "such a program is covered only if its contents constitute a work based"+    , "on the Library (independent of the use of the Library in a tool for"+    , "writing it).  Whether that is true depends on what the Library does"+    , "and what the program that uses the Library does."+    , "  "+    , "  1. You may copy and distribute verbatim copies of the Library's"+    , "complete source code as you receive it, in any medium, provided that"+    , "you conspicuously and appropriately publish on each copy an"+    , "appropriate copyright notice and disclaimer of warranty; keep intact"+    , "all the notices that refer to this License and to the absence of any"+    , "warranty; and distribute a copy of this License along with the"+    , "Library."+    , ""+    , "  You may charge a fee for the physical act of transferring a copy,"+    , "and you may at your option offer warranty protection in exchange for a"+    , "fee."+    , ""+    , "  2. You may modify your copy or copies of the Library or any portion"+    , "of it, thus forming a work based on the Library, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) The modified work must itself be a software library."+    , ""+    , "    b) You must cause the files modified to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    c) You must cause the whole of the work to be licensed at no"+    , "    charge to all third parties under the terms of this License."+    , ""+    , "    d) If a facility in the modified Library refers to a function or a"+    , "    table of data to be supplied by an application program that uses"+    , "    the facility, other than as an argument passed when the facility"+    , "    is invoked, then you must make a good faith effort to ensure that,"+    , "    in the event an application does not supply such function or"+    , "    table, the facility still operates, and performs whatever part of"+    , "    its purpose remains meaningful."+    , ""+    , "    (For example, a function in a library to compute square roots has"+    , "    a purpose that is entirely well-defined independent of the"+    , "    application.  Therefore, Subsection 2d requires that any"+    , "    application-supplied function or table used by this function must"+    , "    be optional: if the application does not supply it, the square"+    , "    root function must still compute square roots.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Library,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Library, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote"+    , "it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Library."+    , ""+    , "In addition, mere aggregation of another work not based on the Library"+    , "with the Library (or with a work based on the Library) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may opt to apply the terms of the ordinary GNU General Public"+    , "License instead of this License to a given copy of the Library.  To do"+    , "this, you must alter all the notices that refer to this License, so"+    , "that they refer to the ordinary GNU General Public License, version 2,"+    , "instead of to this License.  (If a newer version than version 2 of the"+    , "ordinary GNU General Public License has appeared, then you can specify"+    , "that version instead if you wish.)  Do not make any other change in"+    , "these notices."+    , ""+    , "  Once this change is made in a given copy, it is irreversible for"+    , "that copy, so the ordinary GNU General Public License applies to all"+    , "subsequent copies and derivative works made from that copy."+    , ""+    , "  This option is useful when you wish to copy part of the code of"+    , "the Library into a program that is not a library."+    , ""+    , "  4. You may copy and distribute the Library (or a portion or"+    , "derivative of it, under Section 2) in object code or executable form"+    , "under the terms of Sections 1 and 2 above provided that you accompany"+    , "it with the complete corresponding machine-readable source code, which"+    , "must be distributed under the terms of Sections 1 and 2 above on a"+    , "medium customarily used for software interchange."+    , ""+    , "  If distribution of object code is made by offering access to copy"+    , "from a designated place, then offering equivalent access to copy the"+    , "source code from the same place satisfies the requirement to"+    , "distribute the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  5. A program that contains no derivative of any portion of the"+    , "Library, but is designed to work with the Library by being compiled or"+    , "linked with it, is called a \"work that uses the Library\".  Such a"+    , "work, in isolation, is not a derivative work of the Library, and"+    , "therefore falls outside the scope of this License."+    , ""+    , "  However, linking a \"work that uses the Library\" with the Library"+    , "creates an executable that is a derivative of the Library (because it"+    , "contains portions of the Library), rather than a \"work that uses the"+    , "library\".  The executable is therefore covered by this License."+    , "Section 6 states terms for distribution of such executables."+    , ""+    , "  When a \"work that uses the Library\" uses material from a header file"+    , "that is part of the Library, the object code for the work may be a"+    , "derivative work of the Library even though the source code is not."+    , "Whether this is true is especially significant if the work can be"+    , "linked without the Library, or if the work is itself a library.  The"+    , "threshold for this to be true is not precisely defined by law."+    , ""+    , "  If such an object file uses only numerical parameters, data"+    , "structure layouts and accessors, and small macros and small inline"+    , "functions (ten lines or less in length), then the use of the object"+    , "file is unrestricted, regardless of whether it is legally a derivative"+    , "work.  (Executables containing this object code plus portions of the"+    , "Library will still fall under Section 6.)"+    , ""+    , "  Otherwise, if the work is a derivative of the Library, you may"+    , "distribute the object code for the work under the terms of Section 6."+    , "Any executables containing that work also fall under Section 6,"+    , "whether or not they are linked directly with the Library itself."+    , ""+    , "  6. As an exception to the Sections above, you may also compile or"+    , "link a \"work that uses the Library\" with the Library to produce a"+    , "work containing portions of the Library, and distribute that work"+    , "under terms of your choice, provided that the terms permit"+    , "modification of the work for the customer's own use and reverse"+    , "engineering for debugging such modifications."+    , ""+    , "  You must give prominent notice with each copy of the work that the"+    , "Library is used in it and that the Library and its use are covered by"+    , "this License.  You must supply a copy of this License.  If the work"+    , "during execution displays copyright notices, you must include the"+    , "copyright notice for the Library among them, as well as a reference"+    , "directing the user to the copy of this License.  Also, you must do one"+    , "of these things:"+    , ""+    , "    a) Accompany the work with the complete corresponding"+    , "    machine-readable source code for the Library including whatever"+    , "    changes were used in the work (which must be distributed under"+    , "    Sections 1 and 2 above); and, if the work is an executable linked"+    , "    with the Library, with the complete machine-readable \"work that"+    , "    uses the Library\", as object code and/or source code, so that the"+    , "    user can modify the Library and then relink to produce a modified"+    , "    executable containing the modified Library.  (It is understood"+    , "    that the user who changes the contents of definitions files in the"+    , "    Library will not necessarily be able to recompile the application"+    , "    to use the modified definitions.)"+    , ""+    , "    b) Accompany the work with a written offer, valid for at"+    , "    least three years, to give the same user the materials"+    , "    specified in Subsection 6a, above, for a charge no more"+    , "    than the cost of performing this distribution."+    , ""+    , "    c) If distribution of the work is made by offering access to copy"+    , "    from a designated place, offer equivalent access to copy the above"+    , "    specified materials from the same place."+    , ""+    , "    d) Verify that the user has already received a copy of these"+    , "    materials or that you have already sent this user a copy."+    , ""+    , "  For an executable, the required form of the \"work that uses the"+    , "Library\" must include any data and utility programs needed for"+    , "reproducing the executable from it.  However, as a special exception,"+    , "the source code distributed need not include anything that is normally"+    , "distributed (in either source or binary form) with the major"+    , "components (compiler, kernel, and so on) of the operating system on"+    , "which the executable runs, unless that component itself accompanies"+    , "the executable."+    , ""+    , "  It may happen that this requirement contradicts the license"+    , "restrictions of other proprietary libraries that do not normally"+    , "accompany the operating system.  Such a contradiction means you cannot"+    , "use both them and the Library together in an executable that you"+    , "distribute."+    , ""+    , "  7. You may place library facilities that are a work based on the"+    , "Library side-by-side in a single library together with other library"+    , "facilities not covered by this License, and distribute such a combined"+    , "library, provided that the separate distribution of the work based on"+    , "the Library and of the other library facilities is otherwise"+    , "permitted, and provided that you do these two things:"+    , ""+    , "    a) Accompany the combined library with a copy of the same work"+    , "    based on the Library, uncombined with any other library"+    , "    facilities.  This must be distributed under the terms of the"+    , "    Sections above."+    , ""+    , "    b) Give prominent notice with the combined library of the fact"+    , "    that part of it is a work based on the Library, and explaining"+    , "    where to find the accompanying uncombined form of the same work."+    , ""+    , "  8. You may not copy, modify, sublicense, link with, or distribute"+    , "the Library except as expressly provided under this License.  Any"+    , "attempt otherwise to copy, modify, sublicense, link with, or"+    , "distribute the Library is void, and will automatically terminate your"+    , "rights under this License.  However, parties who have received copies,"+    , "or rights, from you under this License will not have their licenses"+    , "terminated so long as such parties remain in full compliance."+    , ""+    , "  9. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Library or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Library (or any work based on the"+    , "Library), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Library or works based on it."+    , ""+    , "  10. Each time you redistribute the Library (or any work based on the"+    , "Library), the recipient automatically receives a license from the"+    , "original licensor to copy, distribute, link with or modify the Library"+    , "subject to these terms and conditions.  You may not impose any further"+    , "restrictions on the recipients' exercise of the rights granted herein."+    , "You are not responsible for enforcing compliance by third parties to"+    , "this License."+    , ""+    , "  11. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Library at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Library by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Library."+    , ""+    , "If any portion of this section is held invalid or unenforceable under any"+    , "particular circumstance, the balance of the section is intended to apply,"+    , "and the section as a whole is intended to apply in other circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  12. If the distribution and/or use of the Library is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Library under this License may add"+    , "an explicit geographical distribution limitation excluding those countries,"+    , "so that distribution is permitted only in or among countries not thus"+    , "excluded.  In such case, this License incorporates the limitation as if"+    , "written in the body of this License."+    , ""+    , "  13. The Free Software Foundation may publish revised and/or new"+    , "versions of the Library General Public License from time to time."+    , "Such new versions will be similar in spirit to the present version,"+    , "but may differ in detail to address new problems or concerns."+    , ""+    , "Each version is given a distinguishing version number.  If the Library"+    , "specifies a version number of this License which applies to it and"+    , "\"any later version\", you have the option of following the terms and"+    , "conditions either of that version or of any later version published by"+    , "the Free Software Foundation.  If the Library does not specify a"+    , "license version number, you may choose any version ever published by"+    , "the Free Software Foundation."+    , ""+    , "  14. If you wish to incorporate parts of the Library into other free"+    , "programs whose distribution conditions are incompatible with these,"+    , "write to the author to ask for permission.  For software which is"+    , "copyrighted by the Free Software Foundation, write to the Free"+    , "Software Foundation; we sometimes make exceptions for this.  Our"+    , "decision will be guided by the two goals of preserving the free status"+    , "of all derivatives of our free software and of promoting the sharing"+    , "and reuse of software generally."+    , ""+    , "                     NO WARRANTY"+    , ""+    , "  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"+    , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."+    , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"+    , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"+    , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"+    , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"+    , "LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"+    , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"+    , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"+    , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"+    , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"+    , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"+    , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"+    , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"+    , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"+    , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"+    , "DAMAGES."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "           How to Apply These Terms to Your New Libraries"+    , ""+    , "  If you develop a new library, and you want it to be of the greatest"+    , "possible use to the public, we recommend making it free software that"+    , "everyone can redistribute and change.  You can do so by permitting"+    , "redistribution under these terms (or, alternatively, under the terms of the"+    , "ordinary General Public License)."+    , ""+    , "  To apply these terms, attach the following notices to the library.  It is"+    , "safest to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least the"+    , "\"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the library's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This library is free software; you can redistribute it and/or"+    , "    modify it under the terms of the GNU Library General Public"+    , "    License as published by the Free Software Foundation; either"+    , "    version 2 of the License, or (at your option) any later version."+    , ""+    , "    This library 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"+    , "    Library General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU Library General Public"+    , "    License along with this library; if not, write to the Free"+    , "    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the library, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the"+    , "  library `Frob' (a library for tweaking knobs) written by James Random Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1990"+    , "  Ty Coon, President of Vice"+    , ""+    , "That's all there is to it!"+    ]++lgpl3 :: License+lgpl3 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , ""+    , "  This version of the GNU Lesser General Public License incorporates"+    , "the terms and conditions of version 3 of the GNU General Public"+    , "License, supplemented by the additional permissions listed below."+    , ""+    , "  0. Additional Definitions. "+    , ""+    , "  As used herein, \"this License\" refers to version 3 of the GNU Lesser"+    , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU"+    , "General Public License."+    , ""+    , "  \"The Library\" refers to a covered work governed by this License,"+    , "other than an Application or a Combined Work as defined below."+    , ""+    , "  An \"Application\" is any work that makes use of an interface provided"+    , "by the Library, but which is not otherwise based on the Library."+    , "Defining a subclass of a class defined by the Library is deemed a mode"+    , "of using an interface provided by the Library."+    , ""+    , "  A \"Combined Work\" is a work produced by combining or linking an"+    , "Application with the Library.  The particular version of the Library"+    , "with which the Combined Work was made is also called the \"Linked"+    , "Version\"."+    , ""+    , "  The \"Minimal Corresponding Source\" for a Combined Work means the"+    , "Corresponding Source for the Combined Work, excluding any source code"+    , "for portions of the Combined Work that, considered in isolation, are"+    , "based on the Application, and not on the Linked Version."+    , ""+    , "  The \"Corresponding Application Code\" for a Combined Work means the"+    , "object code and/or source code for the Application, including any data"+    , "and utility programs needed for reproducing the Combined Work from the"+    , "Application, but excluding the System Libraries of the Combined Work."+    , ""+    , "  1. Exception to Section 3 of the GNU GPL."+    , ""+    , "  You may convey a covered work under sections 3 and 4 of this License"+    , "without being bound by section 3 of the GNU GPL."+    , ""+    , "  2. Conveying Modified Versions."+    , ""+    , "  If you modify a copy of the Library, and, in your modifications, a"+    , "facility refers to a function or data to be supplied by an Application"+    , "that uses the facility (other than as an argument passed when the"+    , "facility is invoked), then you may convey a copy of the modified"+    , "version:"+    , ""+    , "   a) under this License, provided that you make a good faith effort to"+    , "   ensure that, in the event an Application does not supply the"+    , "   function or data, the facility still operates, and performs"+    , "   whatever part of its purpose remains meaningful, or"+    , ""+    , "   b) under the GNU GPL, with none of the additional permissions of"+    , "   this License applicable to that copy."+    , ""+    , "  3. Object Code Incorporating Material from Library Header Files."+    , ""+    , "  The object code form of an Application may incorporate material from"+    , "a header file that is part of the Library.  You may convey such object"+    , "code under terms of your choice, provided that, if the incorporated"+    , "material is not limited to numerical parameters, data structure"+    , "layouts and accessors, or small macros, inline functions and templates"+    , "(ten or fewer lines in length), you do both of the following:"+    , ""+    , "   a) Give prominent notice with each copy of the object code that the"+    , "   Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the object code with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "  4. Combined Works."+    , ""+    , "  You may convey a Combined Work under terms of your choice that,"+    , "taken together, effectively do not restrict modification of the"+    , "portions of the Library contained in the Combined Work and reverse"+    , "engineering for debugging such modifications, if you also do each of"+    , "the following:"+    , ""+    , "   a) Give prominent notice with each copy of the Combined Work that"+    , "   the Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the Combined Work with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "   c) For a Combined Work that displays copyright notices during"+    , "   execution, include the copyright notice for the Library among"+    , "   these notices, as well as a reference directing the user to the"+    , "   copies of the GNU GPL and this license document."+    , ""+    , "   d) Do one of the following:"+    , ""+    , "       0) Convey the Minimal Corresponding Source under the terms of this"+    , "       License, and the Corresponding Application Code in a form"+    , "       suitable for, and under terms that permit, the user to"+    , "       recombine or relink the Application with a modified version of"+    , "       the Linked Version to produce a modified Combined Work, in the"+    , "       manner specified by section 6 of the GNU GPL for conveying"+    , "       Corresponding Source."+    , ""+    , "       1) Use a suitable shared library mechanism for linking with the"+    , "       Library.  A suitable mechanism is one that (a) uses at run time"+    , "       a copy of the Library already present on the user's computer"+    , "       system, and (b) will operate properly with a modified version"+    , "       of the Library that is interface-compatible with the Linked"+    , "       Version. "+    , ""+    , "   e) Provide Installation Information, but only if you would otherwise"+    , "   be required to provide such information under section 6 of the"+    , "   GNU GPL, and only to the extent that such information is"+    , "   necessary to install and execute a modified version of the"+    , "   Combined Work produced by recombining or relinking the"+    , "   Application with a modified version of the Linked Version. (If"+    , "   you use option 4d0, the Installation Information must accompany"+    , "   the Minimal Corresponding Source and Corresponding Application"+    , "   Code. If you use option 4d1, you must provide the Installation"+    , "   Information in the manner specified by section 6 of the GNU GPL"+    , "   for conveying Corresponding Source.)"+    , ""+    , "  5. Combined Libraries."+    , ""+    , "  You may place library facilities that are a work based on the"+    , "Library side by side in a single library together with other library"+    , "facilities that are not Applications and are not covered by this"+    , "License, and convey such a combined library under terms of your"+    , "choice, if you do both of the following:"+    , ""+    , "   a) Accompany the combined library with a copy of the same work based"+    , "   on the Library, uncombined with any other library facilities,"+    , "   conveyed under the terms of this License."+    , ""+    , "   b) Give prominent notice with the combined library that part of it"+    , "   is a work based on the Library, and explaining where to find the"+    , "   accompanying uncombined form of the same work."+    , ""+    , "  6. Revised Versions of the GNU Lesser General Public License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions"+    , "of the GNU Lesser General Public License from time to time. Such new"+    , "versions will be similar in spirit to the present version, but may"+    , "differ in detail to address new problems or concerns."+    , ""+    , "  Each version is given a distinguishing version number. If the"+    , "Library as you received it specifies that a certain numbered version"+    , "of the GNU Lesser General Public License \"or any later version\""+    , "applies to it, you have the option of following the terms and"+    , "conditions either of that published version or of any later version"+    , "published by the Free Software Foundation. If the Library as you"+    , "received it does not specify a version number of the GNU Lesser"+    , "General Public License, you may choose any version of the GNU Lesser"+    , "General Public License ever published by the Free Software Foundation."+    , ""+    , "  If the Library as you received it specifies that a proxy can decide"+    , "whether future versions of the GNU Lesser General Public License shall"+    , "apply, that proxy's public statement of acceptance of any version is"+    , "permanent authorization for you to choose that version for the"+    , "Library."+    ]+
+ Distribution/Client/Init/Types.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Types+-- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Some types used by the 'cabal init' command.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Types where++import Distribution.Simple.Setup+  ( Flag(..) )++import Distribution.Version+import qualified Distribution.Package as P+import Distribution.License+import Distribution.ModuleName++import qualified Text.PrettyPrint as Disp+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Text++import Data.Monoid++-- | InitFlags is really just a simple type to represent certain+--   portions of a .cabal file.  Rather than have a flag for EVERY+--   possible field, we just have one for each field that the user is+--   likely to want and/or that we are likely to be able to+--   intelligently guess.+data InitFlags =+    InitFlags { nonInteractive :: Flag Bool+              , quiet          :: Flag Bool+              , packageDir     :: Flag FilePath+              , noComments     :: Flag Bool+              , minimal        :: Flag Bool++              , packageName  :: Flag String+              , version      :: Flag Version+              , cabalVersion :: Flag VersionRange+              , license      :: Flag License+              , author       :: Flag String+              , email        :: Flag String+              , homepage     :: Flag String++              , synopsis     :: Flag String+              , category     :: Flag (Either String Category)++              , packageType  :: Flag PackageType++              , exposedModules :: Maybe [ModuleName]+              , otherModules   :: Maybe [ModuleName]++              , dependencies :: Maybe [P.Dependency]+              , sourceDirs   :: Maybe [String]+              , buildTools   :: Maybe [String]+              }+  deriving (Show)++data PackageType = Library | Executable+  deriving (Show, Read, Eq)++instance Text PackageType where+  disp = Disp.text . show+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]++instance Monoid InitFlags where+  mempty = InitFlags+    { nonInteractive = mempty+    , quiet          = mempty+    , packageDir     = mempty+    , noComments     = mempty+    , minimal        = mempty+    , packageName    = mempty+    , version        = mempty+    , cabalVersion   = mempty+    , license        = mempty+    , author         = mempty+    , email          = mempty+    , homepage       = mempty+    , synopsis       = mempty+    , category       = mempty+    , packageType    = mempty+    , exposedModules = mempty+    , otherModules   = mempty+    , dependencies   = mempty+    , sourceDirs     = mempty+    , buildTools     = mempty+    }+  mappend  a b = InitFlags+    { nonInteractive = combine nonInteractive+    , quiet          = combine quiet+    , packageDir     = combine packageDir+    , noComments     = combine noComments+    , minimal        = combine minimal+    , packageName    = combine packageName+    , version        = combine version+    , cabalVersion   = combine cabalVersion+    , license        = combine license+    , author         = combine author+    , email          = combine email+    , homepage       = combine homepage+    , synopsis       = combine synopsis+    , category       = combine category+    , packageType    = combine packageType+    , exposedModules = combine exposedModules+    , otherModules   = combine otherModules+    , dependencies   = combine dependencies+    , sourceDirs     = combine sourceDirs+    , buildTools     = combine buildTools+    }+    where combine field = field a `mappend` field b++-- | Some common package categories.+data Category+    = Codec+    | Concurrency+    | Control+    | Data+    | Database+    | Development+    | Distribution+    | Game+    | Graphics+    | Language+    | Math+    | Network+    | Sound+    | System+    | Testing+    | Text+    | Web+    deriving (Read, Show, Eq, Ord, Bounded, Enum)++instance Text Category where+  disp  = Disp.text . show+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]++#if MIN_VERSION_base(3,0,0)+#else+-- Compat instance for ghc-6.6 era+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)+#endif
+ Distribution/Client/Install.hs view
@@ -0,0 +1,875 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) 2005 David Himmelstrup+--                    2007 Bjorn Bringert+--                    2007-2010 Duncan Coutts+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Distribution.Client.Install (+    install,+    upgrade,+  ) where++import Data.List+         ( unfoldr, find, nub, sort )+import Data.Maybe+         ( isJust, fromMaybe )+import Control.Exception as Exception+         ( handleJust )+#if MIN_VERSION_base(4,0,0)+import Control.Exception as Exception+         ( Exception(toException), catches, Handler(Handler), IOException )+import System.Exit+         ( ExitCode )+#else+import Control.Exception as Exception+         ( Exception(IOException, ExitException) )+#endif+import Distribution.Compat.Exception+         ( SomeException, catchIO, catchExit )+import Control.Monad+         ( when, unless )+import System.Directory+         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )+import System.FilePath+         ( (</>), (<.>), takeDirectory )+import System.IO+         ( openFile, IOMode(AppendMode) )+import System.IO.Error+         ( isDoesNotExistError, ioeGetFileName )++import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)+-- import qualified Distribution.Client.Info as Info+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, getInstalledPackages )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup+         ( GlobalFlags(..)+         , ConfigFlags(..), configureCommand, filterConfigureFlags+         , ConfigExFlags(..), InstallFlags(..) )+import Distribution.Client.Config+         ( defaultCabalDir )+import Distribution.Client.Tar (extractTarGzFile)+import Distribution.Client.Types as Available+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports+import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeAnonymous, storeLocal, fromInstallPlan )+import qualified Distribution.Client.InstallSymlink as InstallSymlink+         ( symlinkBinaries )+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import qualified Distribution.Client.World as World+import Paths_cabal_install_bundle (getBinDir)++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId), compilerFlavor+         , PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)+import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Simple.Setup+         ( haddockCommand, HaddockFlags(..), emptyHaddockFlags+         , buildCommand, BuildFlags(..), emptyBuildFlags+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.Setup as Cabal+         ( installCommand, InstallFlags(..), emptyInstallFlags )+import Distribution.Simple.Utils+         ( rawSystemExit, comparing )+import Distribution.Simple.InstallDirs as InstallDirs+         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate+         , initialPathTemplateEnv, installDirsTemplateEnv )+import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion+         , Package(..), PackageFixedDeps(..)+         , Dependency(..), thisPackageVersion )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Version+         ( Version, anyVersion, thisVersion )+import Distribution.Simple.Utils as Utils+         ( notice, info, debug, warn, die, intercalate, withTempDirectory )+import Distribution.Client.Utils+         ( inDir, mergeBy, MergeResult(..) )+import Distribution.System+         ( Platform, buildPlatform, OS(Windows), buildOS )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+         ( Verbosity, showForCabal, verbose )+import Distribution.Simple.BuildPaths ( exeExtension )++--TODO:+-- * assign flags to packages individually+--   * complain about flags that do not apply to any package given as target+--     so flags do not apply to dependencies, only listed, can use flag+--     constraints for dependencies+--   * only record applicable flags in world file+-- * allow flag constraints+-- * allow installed constraints+-- * allow flag and installed preferences+-- * change world file to use cabal section syntax+--   * allow persistent configure flags for each package individually++-- ------------------------------------------------------------+-- * Top level user actions+-- ------------------------------------------------------------++-- | Installs the packages needed to satisfy a list of dependencies.+--+install, upgrade+  :: Verbosity+  -> PackageDBStack+  -> [Repo]+  -> Compiler+  -> ProgramConfiguration+  -> GlobalFlags+  -> ConfigFlags+  -> ConfigExFlags+  -> InstallFlags+  -> [UserTarget]+  -> IO ()+install verbosity packageDBs repos comp conf+  globalFlags configFlags configExFlags installFlags userTargets0 = do++    installed     <- getInstalledPackages verbosity comp packageDBs conf+    availableDb   <- getAvailablePackages verbosity repos++    let -- For install, if no target is given it means we use the+        -- current directory as the single target+        userTargets | null userTargets0 = [UserTargetLocalDir "."]+                    | otherwise         = userTargets0++    pkgSpecifiers <- resolveUserTargets verbosity+                       globalFlags (packageIndex availableDb) userTargets++    notice verbosity "Resolving dependencies..."+    installPlan   <- foldProgress logMsg die return $+                       planPackages+                         comp configFlags configExFlags installFlags+                         installed availableDb pkgSpecifiers++    printPlanMessages verbosity installed installPlan dryRun++    unless dryRun $ do+      installPlan' <- performInstallations verbosity+                        context installed installPlan+      postInstallActions verbosity context userTargets installPlan'++  where+    context :: InstallContext+    context = (packageDBs, repos, comp, conf,+               globalFlags, configFlags, configExFlags, installFlags)++    dryRun      = fromFlag (installDryRun installFlags)+    logMsg message rest = debug verbosity message >> rest+++upgrade _ _ _ _ _ _ _ _ _ _ = die $+    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."++type InstallContext = ( PackageDBStack+                      , [Repo]+                      , Compiler+                      , ProgramConfiguration+                      , GlobalFlags+                      , ConfigFlags+                      , ConfigExFlags+                      , InstallFlags )++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Compiler+             -> ConfigFlags+             -> ConfigExFlags+             -> InstallFlags+             -> PackageIndex InstalledPackage+             -> AvailablePackageDb+             -> [PackageSpecifier AvailablePackage]+             -> Progress String String InstallPlan+planPackages comp configFlags configExFlags installFlags+             installed availableDb pkgSpecifiers =++        resolveDependencies+          buildPlatform (compilerId comp)+          resolverParams++    >>= if onlyDeps then adjustPlanOnlyDeps else return++  where+    resolverParams =++        setPreferenceDefault (if upgradeDeps then PreferAllLatest+                                             else PreferLatestForSelected)++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | Dependency name ver <- configPreferences configExFlags ]++      . addConstraints+          -- version constraints from the config file or command line+          [ PackageVersionConstraint name ver+          | Dependency name ver <- configConstraints configFlags ]++      . addConstraints+          --FIXME: this just applies all flags to all targets which+          -- is silly. We should check if the flags are appropriate+          [ PackageFlagsConstraint (pkgSpecifierTarget pkgSpecifier) flags+          | let flags = configConfigurationsFlags configFlags+          , not (null flags)+          , pkgSpecifier <- pkgSpecifiers ]++      . (if reinstall then reinstallTargets else id)++      $ standardInstallPolicy installed availableDb pkgSpecifiers++    --TODO: this is a general feature and should be moved to D.C.Dependency+    -- Also, the InstallPlan.remove should return info more precise to the+    -- problem, rather than the very general PlanProblem type.+    adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan+    adjustPlanOnlyDeps =+        either (Fail . explain) Done+      . InstallPlan.remove isTarget+      where+        isTarget pkg = packageName pkg `elem` targetnames+        targetnames  = map pkgSpecifierTarget pkgSpecifiers++        explain :: [InstallPlan.PlanProblem] -> String+        explain problems =+            "Cannot select only the dependencies (as requested by the "+         ++ "'--only-dependencies' flag), "+         ++ (case pkgids of+               [pkgid] -> "the package " ++ display pkgid ++ " is "+               _       -> "the packages "+                       ++ intercalate ", " (map display pkgids) ++ " are ")+         ++ "required by a dependency of one of the other targets."+          where+            pkgids =+              nub [ depid+                  | InstallPlan.PackageMissingDeps _ depids <- problems+                  , depid <- depids+                  , packageName depid `elem` targetnames ]++    reinstall   = fromFlag (installReinstall installFlags)+    upgradeDeps = fromFlag (installUpgradeDeps installFlags)+    onlyDeps    = fromFlag (installOnlyDeps installFlags)++-- ------------------------------------------------------------+-- * Informational messages+-- ------------------------------------------------------------++printPlanMessages :: Verbosity+                  -> PackageIndex InstalledPackage+                  -> InstallPlan+                  -> Bool+                  -> IO ()+printPlanMessages verbosity installed installPlan dryRun = do++  when nothingToInstall $+    notice verbosity $+         "No packages to be installed. All the requested packages are "+      ++ "already installed.\n If you want to reinstall anyway then use "+      ++ "the --reinstall flag."++  when (dryRun || verbosity >= verbose) $+    printDryRun verbosity installed installPlan++  where+    nothingToInstall = null (InstallPlan.ready installPlan)+++printDryRun :: Verbosity+            -> PackageIndex InstalledPackage+            -> InstallPlan+            -> IO ()+printDryRun verbosity installed plan = case unfoldr next plan of+  []   -> return ()+  pkgs+    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+        "In order, the following would be installed:"+      : map showPkgAndReason pkgs+    | otherwise -> notice verbosity $ unlines $+        "In order, the following would be installed (use -v for more details):"+      : map (display . packageId) pkgs+  where+    next plan' = case InstallPlan.ready plan' of+      []      -> Nothing+      (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')+        where pkgid = packageId pkg+              result = BuildOk DocsNotTried TestsNotTried+              --FIXME: This is a bit of a hack,+              -- pretending that each package is installed++    showPkgAndReason pkg' = display (packageId pkg') ++ " " +++          case PackageIndex.lookupPackageName installed (packageName pkg') of+            [] -> "(new package)"+            ps ->  case find ((==packageId pkg') . packageId) ps of+              Nothing  -> "(new version)"+              Just pkg -> "(reinstall)" ++ case changes pkg pkg' of+                []   -> ""+                diff -> " changes: "  ++ intercalate ", " diff+    changes pkg pkg' = map change . filter changed+                     $ mergeBy (comparing packageName)+                         (nub . sort . depends $ pkg)+                         (nub . sort . depends $ pkg')+    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"+    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "+                                    ++ display (packageVersion pkgid')+    change (OnlyInRight      pkgid') = display pkgid' ++ " added"+    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'+    changed _                        = True++-- ------------------------------------------------------------+-- * Post installation stuff+-- ------------------------------------------------------------++-- | Various stuff we do after successful or unsuccessfully installing a bunch+-- of packages. This includes:+--+--  * build reporting, local and remote+--  * symlinking binaries+--  * updating indexes+--  * updating world file+--  * error reporting+--+postInstallActions :: Verbosity+                   -> InstallContext+                   -> [UserTarget]+                   -> InstallPlan+                   -> IO ()+postInstallActions verbosity+  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)+  targets installPlan = do++  unless oneShot $+    World.insert verbosity worldFile+      --FIXME: does not handle flags+      [ World.WorldPkgInfo dep []+      | UserTargetNamed dep <- targets ]++  let buildReports = BuildReports.fromInstallPlan installPlan+  BuildReports.storeLocal (installSummaryFile installFlags) buildReports+  when (reportingLevel >= AnonymousReports) $+    BuildReports.storeAnonymous buildReports+  when (reportingLevel == DetailedReports) $+    storeDetailedBuildReports verbosity logsDir buildReports++  regenerateHaddockIndex verbosity packageDBs comp conf+                         configFlags installFlags installPlan++  symlinkBinaries verbosity configFlags installFlags installPlan++  printBuildFailures installPlan++  where+    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)+    oneShot        = fromFlag (installOneShot installFlags)+    worldFile      = fromFlag $ globalWorldFile globalFlags++storeDetailedBuildReports :: Verbosity -> FilePath+                          -> [(BuildReports.BuildReport, Repo)] -> IO ()+storeDetailedBuildReports verbosity logsDir reports = sequence_+  [ do dotCabal <- defaultCabalDir+       let logFileName = display (BuildReports.package report) <.> "log"+           logFile     = logsDir </> logFileName+           reportsDir  = dotCabal </> "reports" </> remoteRepoName remoteRepo+           reportFile  = reportsDir </> logFileName++       handleMissingLogFile $ do+         buildLog <- readFile logFile+         createDirectoryIfMissing True reportsDir -- FIXME+         writeFile reportFile (show (BuildReports.show report, buildLog))++  | (report, Repo { repoKind = Left remoteRepo }) <- reports+  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]++  where+    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True+    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True+    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True+    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True+    isLikelyToHaveLogFile _                               = False++    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->+      warn verbosity $ "Missing log file for build report: "+                    ++ fromMaybe ""  (ioeGetFileName ioe)++#if MIN_VERSION_base(4,0,0)+    missingFile ioe+#else+    missingFile (IOException ioe)+#endif+      | isDoesNotExistError ioe  = Just ioe+    missingFile _                = Nothing+++regenerateHaddockIndex :: Verbosity+                       -> [PackageDB]+                       -> Compiler+                       -> ProgramConfiguration+                       -> ConfigFlags+                       -> InstallFlags+                       -> InstallPlan+                       -> IO ()+regenerateHaddockIndex verbosity packageDBs comp conf+                       configFlags installFlags installPlan+  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   (compilerFlavor comp)+                   (fromFlag (configUserInstall configFlags))+                   True+  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)+      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate++  notice verbosity $+     "Updating documentation index " ++ indexFile++  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo+  installed <- getInstalledPackages verbosity comp packageDBs conf+  Haddock.regenerateHaddockIndex verbosity installed conf indexFile++  | otherwise = return ()+  where+    haddockIndexFileIsRequested =+         fromFlag (installDocumentation installFlags)+      && isJust (flagToMaybe (installHaddockIndex installFlags))++    -- We want to regenerate the index if some new documentation was actually+    -- installed. Since the index is per-user, we don't do it for global+    -- installs or special cases where we're installing into a specific db.+    shouldRegenerateHaddockIndex = normalUserInstall+                                && someDocsWereInstalled installPlan+      where+        someDocsWereInstalled = any installedDocs . InstallPlan.toList+        normalUserInstall     = (UserPackageDB `elem` packageDBs)+                             && all (not . isSpecificPackageDB) packageDBs++        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True+        installedDocs _                                            = False+        isSpecificPackageDB (SpecificPackageDB _) = True+        isSpecificPackageDB _                     = False++    substHaddockIndexFileName defaultDirs = fromPathTemplate+                                          . substPathTemplate env+      where+        env  = env0 ++ installDirsTemplateEnv absoluteDirs+        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)+            ++ InstallDirs.platformTemplateEnv (buildPlatform)+        absoluteDirs = InstallDirs.substituteInstallDirTemplates+                         env0 templateDirs+        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                         defaultDirs (configInstallDirs configFlags)+++symlinkBinaries :: Verbosity+                -> ConfigFlags+                -> InstallFlags+                -> InstallPlan -> IO ()+symlinkBinaries verbosity configFlags installFlags plan = do+  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan+  case failed of+    [] -> return ()+    [(_, exe, path)] ->+      warn verbosity $+           "could not create a symlink in " ++ bindir ++ " for "+        ++ exe ++ " because the file exists there already but is not "+        ++ "managed by cabal. You can create a symlink for this executable "+        ++ "manually if you wish. The executable file has been installed at "+        ++ path+    exes ->+      warn verbosity $+           "could not create symlinks in " ++ bindir ++ " for "+        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]+        ++ " because the files exist there already and are not "+        ++ "managed by cabal. You can create symlinks for these executables "+        ++ "manually if you wish. The executable files have been installed at "+        ++ intercalate ", " [ path | (_, _, path) <- exes ]+  where+    bindir = fromFlag (installSymlinkBinDir installFlags)+++printBuildFailures :: InstallPlan -> IO ()+printBuildFailures plan =+  case [ (pkg, reason)+       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of+    []     -> return ()+    failed -> die . unlines+            $ "Error: some packages failed to install:"+            : [ display (packageId pkg) ++ printFailureReason reason+              | (pkg, reason) <- failed ]+  where+    printFailureReason reason = case reason of+      DependentFailed pkgid -> " depends on " ++ display pkgid+                            ++ " which failed to install."+      DownloadFailed  e -> " failed while downloading the package."+                        ++ " The exception was:\n  " ++ show e+      UnpackFailed    e -> " failed while unpacking the package."+                        ++ " The exception was:\n  " ++ show e+      ConfigureFailed e -> " failed during the configure step."+                        ++ " The exception was:\n  " ++ show e+      BuildFailed     e -> " failed during the building phase."+                        ++ " The exception was:\n  " ++ show e+      InstallFailed   e -> " failed during the final install step."+                        ++ " The exception was:\n  " ++ show e+++-- ------------------------------------------------------------+-- * Actually do the installations+-- ------------------------------------------------------------++data InstallMisc = InstallMisc {+    rootCmd    :: Maybe FilePath,+    libVersion :: Maybe Version+  }++performInstallations :: Verbosity+                     -> InstallContext+                     -> PackageIndex InstalledPackage+                     -> InstallPlan+                     -> IO InstallPlan+performInstallations verbosity+  (packageDBs, _, comp, conf,+   globalFlags, configFlags, configExFlags, installFlags)+  installed installPlan = do++  executeInstallPlan installPlan $ \cpkg ->+    installConfiguredPackage platform compid configFlags+                             cpkg $ \configFlags' src pkg ->+      fetchAvailablePackage verbosity src $ \src' ->+        installLocalPackage verbosity (packageId pkg) src' $ \mpath ->+          installUnpackedPackage verbosity (setupScriptOptions installed)+                                 miscOptions configFlags' installFlags+                                 compid pkg mpath useLogFile++  where+    platform = InstallPlan.planPlatform installPlan+    compid   = InstallPlan.planCompiler installPlan++    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),+      useCompiler      = Just comp,+      -- Hack: we typically want to allow the UserPackageDB for finding the+      -- Cabal lib when compiling any Setup.hs even if we're doing a global+      -- install. However we also allow looking in a specific package db.+      usePackageDB     = if UserPackageDB `elem` packageDBs+                           then packageDBs+                           else let (db@GlobalPackageDB:dbs) = packageDBs+                                 in db : UserPackageDB : dbs,+                                --TODO: use Ord instance:+                                -- insert UserPackageDB packageDBs+      usePackageIndex  = if UserPackageDB `elem` packageDBs+                           then Just index+                           else Nothing,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }+    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)+    useLogFile :: Maybe (PackageIdentifier -> FilePath)+    useLogFile = fmap substLogFileName logFileTemplate+      where+        logFileTemplate :: Maybe PathTemplate+        logFileTemplate --TODO: separate policy from mechanism+          | reportingLevel == DetailedReports+          = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"+          | otherwise+          = flagToMaybe (installLogFile installFlags)+    substLogFileName template pkg = fromPathTemplate+                                  . substPathTemplate env+                                  $ template+      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+    miscOptions  = InstallMisc {+      rootCmd    = if fromFlag (configUserInstall configFlags)+                     then Nothing      -- ignore --root-cmd if --user.+                     else flagToMaybe (installRootCmd installFlags),+      libVersion = flagToMaybe (configCabalVersion configExFlags)+    }+++executeInstallPlan :: Monad m+                   => InstallPlan+                   -> (ConfiguredPackage -> m BuildResult)+                   -> m InstallPlan+executeInstallPlan plan installPkg = case InstallPlan.ready plan of+  []       -> return plan+  (pkg: _) -> do buildResult <- installPkg pkg+                 let plan' = updatePlan (packageId pkg) buildResult plan+                 executeInstallPlan plan' installPkg+  where+    updatePlan pkgid (Right buildSuccess) =+      InstallPlan.completed pkgid buildSuccess++    updatePlan pkgid (Left buildFailure) =+      InstallPlan.failed    pkgid buildFailure depsFailure+      where+        depsFailure = DependentFailed pkgid+        -- So this first pkgid failed for whatever reason (buildFailure).+        -- All the other packages that depended on this pkgid, which we+        -- now cannot build, we mark as failing due to 'DependentFailed'+        -- which kind of means it was not their fault.+++-- | Call an installer for an 'AvailablePackage' but override the configure+-- flags with the ones given by the 'ConfiguredPackage'. In particular the+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- versioned package dependencies. So we ignore any previous partial flag+-- assignment or dependency constraints and use the new ones.+--+installConfiguredPackage :: Platform -> CompilerId+                         ->  ConfigFlags -> ConfiguredPackage+                         -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                         -> PackageDescription -> a)+                         -> a+installConfiguredPackage platform comp configFlags+  (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)+  installPkg = installPkg configFlags {+    configConfigurationsFlags = flags,+    configConstraints = map thisPackageVersion deps+  } source pkg+  where+    pkg = case finalizePackageDescription flags+           (const True)+           platform comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc++fetchAvailablePackage+  :: Verbosity+  -> PackageLocation (Maybe FilePath)+  -> (PackageLocation FilePath -> IO BuildResult)+  -> IO BuildResult+fetchAvailablePackage verbosity src installPkg = do+  fetched <- checkFetched src+  case fetched of+    Just src' -> installPkg src'+    Nothing   -> onFailure DownloadFailed $+                   fetchPackage verbosity src >>= installPkg+++installLocalPackage+  :: Verbosity -> PackageIdentifier -> PackageLocation FilePath+  -> (Maybe FilePath -> IO BuildResult)+  -> IO BuildResult+installLocalPackage verbosity pkgid location installPkg = case location of++    LocalUnpackedPackage dir ->+      installPkg (Just dir)++    LocalTarballPackage tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg++    RemoteTarballPackage _ tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg++    RepoTarballPackage _ _ tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg+++installLocalTarballPackage+  :: Verbosity -> PackageIdentifier -> FilePath+  -> (Maybe FilePath -> IO BuildResult)+  -> IO BuildResult+installLocalTarballPackage verbosity pkgid tarballPath installPkg = do+  tmp <- getTemporaryDirectory+  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->+    onFailure UnpackFailed $ do+      info verbosity $ "Extracting " ++ tarballPath+                    ++ " to " ++ tmpDirPath ++ "..."+      let relUnpackedPath = display pkgid+          absUnpackedPath = tmpDirPath </> relUnpackedPath+          descFilePath = absUnpackedPath+                     </> display (packageName pkgid) <.> "cabal"+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath+      exists <- doesFileExist descFilePath+      when (not exists) $+        die $ "Package .cabal file not found: " ++ show descFilePath+      installPkg (Just absUnpackedPath)+++installUnpackedPackage :: Verbosity+                   -> SetupScriptOptions+                   -> InstallMisc+                   -> ConfigFlags+                   -> InstallFlags+                   -> CompilerId+                   -> PackageDescription+                   -> Maybe FilePath -- ^ Directory to change to before starting the installation.+                   -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)+                   -> IO BuildResult+installUnpackedPackage verbosity scriptOptions miscOptions+                       configFlags installConfigFlags+                       compid pkg workingDir useLogFile =++  -- Configure phase+  onFailure ConfigureFailed $ do+    setup configureCommand configureFlags++  -- Build phase+    onFailure BuildFailed $ do+      setup buildCommand' buildFlags++  -- Doc generation phase+      docsResult <- if shouldHaddock+        then (do setup haddockCommand haddockFlags+                 return DocsOk)+               `catchIO`   (\_ -> return DocsFailed)+               `catchExit` (\_ -> return DocsFailed)+        else return DocsNotTried++  -- Tests phase+      testsResult <- return TestsNotTried  --TODO: add optional tests++  -- Install phase+      onFailure InstallFailed $+        withWin32SelfUpgrade verbosity configFlags compid pkg $ do+          case rootCmd miscOptions of+            (Just cmd) -> reexec cmd+            Nothing    -> setup Cabal.installCommand installFlags+          return (Right (BuildOk docsResult testsResult))++  where+    configureFlags   = filterConfigureFlags configFlags {+      configVerbosity = toFlag verbosity'+    }+    buildCommand'    = buildCommand defaultProgramConfiguration+    buildFlags   _   = emptyBuildFlags {+      buildDistPref  = configDistPref configFlags,+      buildVerbosity = toFlag verbosity'+    }+    shouldHaddock    = fromFlag (installDocumentation installConfigFlags)+    haddockFlags _   = emptyHaddockFlags {+      haddockDistPref  = configDistPref configFlags,+      haddockVerbosity = toFlag verbosity'+    }+    installFlags _   = Cabal.emptyInstallFlags {+      Cabal.installDistPref  = configDistPref configFlags,+      Cabal.installVerbosity = toFlag verbosity'+    }+    verbosity' | isJust useLogFile = max Verbosity.verbose verbosity+               | otherwise         = verbosity+    setup cmd flags  = do+      logFileHandle <- case useLogFile of+        Nothing          -> return Nothing+        Just mkLogFileName -> do+          let logFileName = mkLogFileName (packageId pkg)+              logDir      = takeDirectory logFileName+          unless (null logDir) $ createDirectoryIfMissing True logDir+          logFile <- openFile logFileName AppendMode+          return (Just logFile)++      setupWrapper verbosity+        scriptOptions { useLoggingHandle = logFileHandle+                      , useWorkingDir    = workingDir }+        (Just pkg)+        cmd flags []+    reexec cmd = do+      -- look for our on executable file and re-exec ourselves using+      -- a helper program like sudo to elevate priviledges:+      bindir <- getBinDir+      let self = bindir </> "cabal" <.> exeExtension+      weExist <- doesFileExist self+      if weExist+        then inDir workingDir $+               rawSystemExit verbosity cmd+                 [self, "install", "--only"+                 ,"--verbose=" ++ showForCabal verbosity]+        else die $ "Unable to find cabal executable at: " ++ self+++-- helper+onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult+onFailure result action =+#if MIN_VERSION_base(4,0,0)+  action `catches`+    [ Handler $ \ioe  -> handler (ioe  :: IOException)+    , Handler $ \exit -> handler (exit :: ExitCode)+    ]+  where+    handler :: Exception e => e -> IO BuildResult+    handler = return . Left . result . toException+#else+  action+    `catchIO`   (return . Left . result . IOException)+    `catchExit` (return . Left . result . ExitException)+#endif+++-- ------------------------------------------------------------+-- * Wierd windows hacks+-- ------------------------------------------------------------++withWin32SelfUpgrade :: Verbosity+                     -> ConfigFlags+                     -> CompilerId+                     -> PackageDescription+                     -> IO a -> IO a+withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity configFlags compid pkg action = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   compFlavor+                   (fromFlag (configUserInstall configFlags))+                   (PackageDescription.hasLibs pkg)++  Win32SelfUpgrade.possibleSelfUpgrade verbosity+    (exeInstallPaths defaultDirs) action++  where+    pkgid = packageId pkg+    (CompilerId compFlavor _) = compid++    exeInstallPaths defaultDirs =+      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension+      | exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe)+      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix+            prefix  = substTemplate prefixTemplate+            suffix  = substTemplate suffixTemplate ]+      where+        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)+        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)+        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+        absoluteDirs   = InstallDirs.absoluteInstallDirs+                           pkgid compid InstallDirs.NoCopyDest templateDirs+        substTemplate  = InstallDirs.fromPathTemplate+                       . InstallDirs.substPathTemplate env+          where env = InstallDirs.initialPathTemplateEnv pkgid compid
+ Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,511 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Package installation plan+--+-----------------------------------------------------------------------------+module Distribution.Client.InstallPlan (+  InstallPlan,+  ConfiguredPackage(..),+  PlanPackage(..),++  -- * Operations on 'InstallPlan's+  new,+  toList,+  ready,+  completed,+  failed,+  remove,++  -- ** Query functions+  planPlatform,+  planCompiler,++  -- * Checking valididy of plans+  valid,+  closed,+  consistent,+  acyclic,+  configuredPackageValid,++  -- ** Details on invalid plans+  PlanProblem(..),+  showPlanProblem,+  PackageProblem(..),+  showPackageProblem,+  problems,+  configuredPackageProblems+  ) where++import Distribution.Client.Types+         ( AvailablePackage(packageDescription), ConfiguredPackage(..)+         , InstalledPackage+         , BuildFailure, BuildSuccess )+import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         , PackageFixedDeps(..), Dependency(..) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.PackageDescription+         ( GenericPackageDescription(genPackageFlags)+         , Flag(flagName), FlagName(..) )+import Distribution.Client.PackageUtils+         ( externalBuildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Text+         ( display )+import Distribution.System+         ( Platform )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.Client.Utils+         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )+import Distribution.Simple.Utils+         ( comparing, intercalate )++import Data.List+         ( sort, sortBy )+import Data.Maybe+         ( fromMaybe )+import qualified Data.Graph as Graph+import Data.Graph (Graph)+import Control.Exception+         ( assert )++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- The Problem:+--+-- In general we start with a set of installed packages and a set of available+-- packages.+--+-- Installed packages have fixed dependencies. They have already been built and+-- we know exactly what packages they were built against, including their exact+-- versions. +--+-- Available package have somewhat flexible dependencies. They are specified as+-- version ranges, though really they're predicates. To make matters worse they+-- have conditional flexible dependencies. Configuration flags can affect which+-- packages are required and can place additional constraints on their+-- versions.+--+-- These two sets of package can and usually do overlap. There can be installed+-- packages that are also available which means they could be re-installed if+-- required, though there will also be packages which are not available and+-- cannot be re-installed. Very often there will be extra versions available+-- than are installed. Sometimes we may like to prefer installed packages over+-- available ones or perhaps always prefer the latest available version whether+-- installed or not.+--+-- The goal is to calculate an installation plan that is closed, acyclic and+-- consistent and where every configured package is valid.+--+-- An installation plan is a set of packages that are going to be used+-- together. It will consist of a mixture of installed packages and available+-- packages along with their exact version dependencies. An installation plan+-- is closed if for every package in the set, all of its dependencies are+-- also in the set. It is consistent if for every package in the set, all+-- dependencies which target that package have the same version.++-- Note that plans do not necessarily compose. You might have a valid plan for+-- package A and a valid plan for package B. That does not mean the composition+-- is simultaniously valid for A and B. In particular you're most likely to+-- have problems with inconsistent dependencies.+-- On the other hand it is true that every closed sub plan is valid.++data PlanPackage = PreExisting InstalledPackage+                 | Configured  ConfiguredPackage+                 | Installed   ConfiguredPackage BuildSuccess+                 | Failed      ConfiguredPackage BuildFailure++instance Package PlanPackage where+  packageId (PreExisting pkg) = packageId pkg+  packageId (Configured  pkg) = packageId pkg+  packageId (Installed pkg _) = packageId pkg+  packageId (Failed    pkg _) = packageId pkg++instance PackageFixedDeps PlanPackage where+  depends (PreExisting pkg) = depends pkg+  depends (Configured  pkg) = depends pkg+  depends (Installed pkg _) = depends pkg+  depends (Failed    pkg _) = depends pkg++data InstallPlan = InstallPlan {+    planIndex    :: PackageIndex PlanPackage,+    planGraph    :: Graph,+    planGraphRev :: Graph,+    planPkgOf    :: Graph.Vertex -> PlanPackage,+    planVertexOf :: PackageIdentifier -> Graph.Vertex,+    planPlatform :: Platform,+    planCompiler :: CompilerId+  }++invariant :: InstallPlan -> Bool+invariant plan =+  valid (planPlatform plan) (planCompiler plan) (planIndex plan)++internalError :: String -> a+internalError msg = error $ "InstallPlan: internal error: " ++ msg++-- | Build an installation plan from a valid set of resolved packages.+--+new :: Platform -> CompilerId -> PackageIndex PlanPackage+    -> Either [PlanProblem] InstallPlan+new platform compiler index =+  case problems platform compiler index of+    [] -> Right InstallPlan {+            planIndex    = index,+            planGraph    = graph,+            planGraphRev = Graph.transposeG graph,+            planPkgOf    = vertexToPkgId,+            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,+            planPlatform = platform,+            planCompiler = compiler+          }+      where (graph, vertexToPkgId, pkgIdToVertex) =+              PackageIndex.dependencyGraph index+            noSuchPkgId = internalError "package is not in the graph"+    probs -> Left probs++toList :: InstallPlan -> [PlanPackage]+toList = PackageIndex.allPackages . planIndex++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (PlanPackage -> Bool)+       -> InstallPlan+       -> Either [PlanProblem] InstallPlan+remove shouldRemove plan =+    new (planPlatform plan) (planCompiler plan) newIndex+  where+    newIndex = PackageIndex.fromList $+                 filter (not . shouldRemove) (toList plan)++-- | The packages that are ready to be installed. That is they are in the+-- configured state and have all their dependencies installed already.+-- The plan is complete if the result is @[]@.+--+ready :: InstallPlan -> [ConfiguredPackage]+ready plan = assert check readyPackages+  where+    check = if null readyPackages then null configuredPackages else True+    configuredPackages =+      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]+    readyPackages = filter (all isInstalled . depends) configuredPackages+    isInstalled pkg =+      case PackageIndex.lookupPackageId (planIndex plan) pkg of+        Just (Configured  _) -> False+        Just (Failed    _ _) -> internalError depOnFailed+        Just (PreExisting _) -> True+        Just (Installed _ _) -> True+        Nothing              -> internalError incomplete+    incomplete  = "install plan is not closed"+    depOnFailed = "configured package depends on failed package"++-- | Marks a package in the graph as completed. Also saves the build result for+-- the completed package in the plan.+--+-- * The package must exist in the graph.+-- * The package must have had no uninstalled dependent packages.+--+completed :: PackageIdentifier+          -> BuildSuccess+          -> InstallPlan -> InstallPlan+completed pkgid buildResult plan = assert (invariant plan') plan'+  where+    plan'     = plan {+                  planIndex = PackageIndex.insert installed (planIndex plan)+                }+    installed = Installed (lookupConfiguredPackage plan pkgid) buildResult++-- | Marks a package in the graph as having failed. It also marks all the+-- packages that depended on it as having failed.+--+-- * The package must exist in the graph and be in the configured state.+--+failed :: PackageIdentifier -- ^ The id of the package that failed to install+       -> BuildFailure      -- ^ The build result to use for the failed package+       -> BuildFailure      -- ^ The build result to use for its dependencies+       -> InstallPlan+       -> InstallPlan+failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'+  where+    plan'    = plan {+                 planIndex = PackageIndex.merge (planIndex plan) failures+               }+    pkg      = lookupConfiguredPackage plan pkgid+    failures = PackageIndex.fromList+             $ Failed pkg buildResult+             : [ Failed pkg' buildResult'+               | Just pkg' <- map checkConfiguredPackage+                            $ packagesThatDependOn plan pkgid ]++-- | lookup the reachable packages in the reverse dependency graph+--+packagesThatDependOn :: InstallPlan+                     -> PackageIdentifier -> [PlanPackage]+packagesThatDependOn plan = map (planPkgOf plan)+                          . tail+                          . Graph.reachable (planGraphRev plan)+                          . planVertexOf plan++-- | lookup a package that we expect to be in the configured state+--+lookupConfiguredPackage :: InstallPlan+                        -> PackageIdentifier -> ConfiguredPackage+lookupConfiguredPackage plan pkgid =+  case PackageIndex.lookupPackageId (planIndex plan) pkgid of+    Just (Configured pkg) -> pkg+    _  -> internalError $ "not configured or no such pkg " ++ display pkgid++-- | check a package that we expect to be in the configured or failed state+--+checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage+checkConfiguredPackage (Configured pkg) = Just pkg+checkConfiguredPackage (Failed     _ _) = Nothing+checkConfiguredPackage pkg                =+  internalError $ "not configured or no such pkg " ++ display (packageId pkg)++-- ------------------------------------------------------------+-- * Checking valididy of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is 'acyclic',+-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the+-- plan has to have a valid configuration (see 'configuredPackageValid').+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool+valid platform comp index = null (problems platform comp index)++data PlanProblem =+     PackageInvalid       ConfiguredPackage [PackageProblem]+   | PackageMissingDeps   PlanPackage [PackageIdentifier]+   | PackageCycle         [PlanPackage]+   | PackageInconsistency PackageName [(PackageIdentifier, Version)]+   | PackageStateInvalid  PlanPackage PlanPackage++showPlanProblem :: PlanProblem -> String+showPlanProblem (PackageInvalid pkg packageProblems) =+     "Package " ++ display (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]++showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ display (packageId pkg)+  ++ " depends on the following packages which are missing from the plan "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ display name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ display pkg ++ " requires "+                            ++ display (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ display (packageId pkg')+  ++ " which is in the " ++ showPlanState pkg'+  ++ " state"+  where+    showPlanState (PreExisting _) = "pre-existing"+    showPlanState (Configured  _) = "configured"+    showPlanState (Installed _ _) = "installed"+    showPlanState (Failed    _ _) = "failed"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: Platform -> CompilerId+         -> PackageIndex PlanPackage -> [PlanProblem]+problems platform comp index =+     [ PackageInvalid pkg packageProblems+     | Configured pkg <- PackageIndex.allPackages index+     , let packageProblems = configuredPackageProblems platform comp pkg+     , not (null packageProblems) ]++  ++ [ PackageMissingDeps pkg missingDeps+     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- PackageIndex.dependencyCycles index ]++  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]++  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- PackageIndex.allPackages index+     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)+     , not (stateDependencyRelation pkg pkg') ]++-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.+--+-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out+--   which packages are involved in dependency cycles.+--+acyclic :: PackageIndex PlanPackage -> Bool+acyclic = null . PackageIndex.dependencyCycles++-- | An installation plan is closed if for every package in the set, all of+-- its dependencies are also in the set. That is, the set is closed under the+-- dependency relation.+--+-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out+--   which packages depend on packages not in the index.+--+closed :: PackageIndex PlanPackage -> Bool+closed = null . PackageIndex.brokenPackages++-- | An installation plan is consistent if all dependencies that target a+-- single package name, target the same version.+--+-- This is slightly subtle. It is not the same as requiring that there be at+-- most one version of any package in the set. It only requires that of+-- packages which have more than one other package depending on them. We could+-- actually make the condition even more precise and say that different+-- versions are ok so long as they are not both in the transative closure of+-- any other package (or equivalently that their inverse closures do not+-- intersect). The point is we do not want to have any packages depending+-- directly or indirectly on two different versions of the same package. The+-- current definition is just a safe aproximation of that.+--+-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to+--   find out which packages are.+--+consistent :: PackageIndex PlanPackage -> Bool+consistent = null . PackageIndex.dependencyInconsistencies++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @dependencyStatesOk a b = True@.+--+stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool+stateDependencyRelation (PreExisting _) (PreExisting _) = True++stateDependencyRelation (Configured  _) (PreExisting _) = True+stateDependencyRelation (Configured  _) (Configured  _) = True+stateDependencyRelation (Configured  _) (Installed _ _) = True++stateDependencyRelation (Installed _ _) (PreExisting _) = True+stateDependencyRelation (Installed _ _) (Installed _ _) = True++stateDependencyRelation (Failed    _ _) (PreExisting _) = True+-- failed can depends on configured because a package can depend on+-- several other packages and if one of the deps fail then we fail+-- but we still depend on the other ones that did not fail:+stateDependencyRelation (Failed    _ _) (Configured  _) = True+stateDependencyRelation (Failed    _ _) (Installed _ _) = True+stateDependencyRelation (Failed    _ _) (Failed    _ _) = True++stateDependencyRelation _               _               = False++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- in the configuration given by the flag assignment, all the package+-- dependencies are satisfied by the specified packages.+--+configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool+configuredPackageValid platform comp pkg =+  null (configuredPackageProblems platform comp pkg)++data PackageProblem = DuplicateFlag FlagName+                    | MissingFlag   FlagName+                    | ExtraFlag     FlagName+                    | DuplicateDeps [PackageIdentifier]+                    | MissingDep    Dependency+                    | ExtraDep      PackageIdentifier+                    | InvalidDep    Dependency PackageIdentifier++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag (FlagName flag)) =+  "duplicate flag in the flag assignment: " ++ flag++showPackageProblem (MissingFlag (FlagName flag)) =+  "missing an assignment for the flag: " ++ flag++showPackageProblem (ExtraFlag (FlagName flag)) =+  "extra flag given that is not used by the package: " ++ flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map display pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ display dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ display pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ display dep+  ++ " but the configuration specifies " ++ display pkgid+  ++ " which does not satisfy the dependency."++configuredPackageProblems :: Platform -> CompilerId+                          -> ConfiguredPackage -> [PackageProblem]+configuredPackageProblems platform comp+  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =+     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  where+    mergedFlags = mergeBy compare+      (sort $ map flagName (genPackageFlags (packageDescription pkg)))+      (sort $ map fst specifiedFlags)++    mergedDeps = mergeBy+      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+      (sortBy (comparing dependencyName) requiredDeps)+      (sortBy (comparing packageName)    specifiedDeps)++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _) = name++    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePackageDescription+      case finalizePackageDescription specifiedFlags+         (const True)+         platform comp+         []+         (packageDescription pkg) of+        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg+        Left  _ -> error "configuredPackageInvalidDeps internal error"
+ Distribution/Client/InstallSymlink.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallSymlink+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Managing installing binaries with symlinks.+-----------------------------------------------------------------------------+module Distribution.Client.InstallSymlink (+    symlinkBinaries,+    symlinkBinary,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import Distribution.Package (PackageIdentifier)+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup (InstallFlags)+import Distribution.Simple.Setup (ConfigFlags)++symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries _ _ _ = return []++symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool+symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"++#else++import Distribution.Client.Types+         ( AvailablePackage(..), ConfiguredPackage(..) )+import Distribution.Client.Setup+         ( InstallFlags(installSymlinkBinDir) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)++import Distribution.Package+         ( PackageIdentifier, Package(packageId) )+import Distribution.Compiler+         ( CompilerId(..) )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Simple.Setup+         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.InstallDirs as InstallDirs++import System.Posix.Files+         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink+         , removeLink )+import System.Directory+         ( canonicalizePath )+import System.FilePath+         ( (</>), splitPath, joinPath, isAbsolute )++import Prelude hiding (catch, ioError)+import System.IO.Error+         ( catch, isDoesNotExistError, ioError )+import Control.Exception+         ( assert )+import Data.Maybe+         ( catMaybes )++-- | We would like by default to install binaries into some location that is on+-- the user's PATH. For per-user installations on Unix systems that basically+-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@+-- directory will be on the user's PATH. However some people are a bit nervous+-- about letting a package manager install programs into @~/bin/@.+--+-- A comprimise solution is that instead of installing binaries directly into+-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@+-- and then create symlinks in @~/bin/@. We can be careful when setting up the+-- symlinks that we do not overwrite any binary that the user installed. We can+-- check if it was a symlink we made because it would point to the private dir+-- where we install our binaries. This means we can install normally without+-- worrying and in a later phase set up symlinks, and if that fails then we+-- report it to the user, but even in this case the package is still in an ok+-- installed state.+--+-- This is an optional feature that users can choose to use or not. It is+-- controlled from the config file. Of course it only works on posix systems+-- with symlinks so is not available to Windows users.+--+symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries configFlags installFlags plan =+  case flagToMaybe (installSymlinkBinDir installFlags) of+    Nothing            -> return []+    Just symlinkBinDir+           | null exes -> return []+           | otherwise -> do+      publicBinDir  <- canonicalizePath symlinkBinDir+--    TODO: do we want to do this here? :+--      createDirectoryIfMissing True publicBinDir+      fmap catMaybes $ sequence+        [ do privateBinDir <- pkgBinDir pkg+             ok <- symlinkBinary+                     publicBinDir  privateBinDir+                     publicExeName privateExeName+             if ok+               then return Nothing+               else return (Just (pkgid, publicExeName,+                                  privateBinDir </> privateExeName))+        | (pkg, exe) <- exes+        , let publicExeName  = PackageDescription.exeName exe+              privateExeName = prefix ++ publicExeName ++ suffix+              pkgid  = packageId pkg+              prefix = substTemplate pkgid prefixTemplate+              suffix = substTemplate pkgid suffixTemplate ]+  where+    exes =+      [ (pkg, exe)+      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan+      , let pkg   = pkgDescription cpkg+      , exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]++    pkgDescription :: ConfiguredPackage -> PackageDescription+    pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =+      case finalizePackageDescription flags+             (const True)+             platform compilerId [] pkg of+        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+        Right (desc, _) -> desc++    -- This is sadly rather complicated. We're kind of re-doing part of the+    -- configuration for the package. :-(+    pkgBinDir :: PackageDescription -> IO FilePath+    pkgBinDir pkg = do+      defaultDirs <- InstallDirs.defaultInstallDirs+                       compilerFlavor+                       (fromFlag (configUserInstall configFlags))+                       (PackageDescription.hasLibs pkg)+      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+          absoluteDirs = InstallDirs.absoluteInstallDirs+                           (packageId pkg) compilerId InstallDirs.NoCopyDest+                           templateDirs+      canonicalizePath (InstallDirs.bindir absoluteDirs)++    substTemplate pkgid = InstallDirs.fromPathTemplate+                        . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId++    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)+    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)+    platform         = InstallPlan.planPlatform plan+    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan++symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir+                          --   eg @/home/user/bin@+              -> FilePath -- ^ The canonical path of the private bin dir+                          --   eg @/home/user/.cabal/bin@+              -> String   -- ^ The name of the executable to go in the public+                          --   bin dir, eg @foo@+              -> String   -- ^ The name of the executable to in the private bin+                          --   dir, eg @foo-1.0@+              -> IO Bool  -- ^ If creating the symlink was sucessful. @False@+                          --   if there was another file there already that we+                          --   did not own. Other errors like permission errors+                          --   just propagate as exceptions.+symlinkBinary publicBindir privateBindir publicName privateName = do+  ok <- targetOkToOverwrite (publicBindir </> publicName)+                            (privateBindir </> privateName)+  case ok of+    NotOurFile    ->                     return False+    NotExists     ->           mkLink >> return True+    OkToOverwrite -> rmLink >> mkLink >> return True+  where+    relativeBindir = makeRelative publicBindir privateBindir+    mkLink = createSymbolicLink (relativeBindir </> privateName)+                                (publicBindir   </> publicName)+    rmLink = removeLink (publicBindir </> publicName)++-- | Check a filepath of a symlink that we would like to create to see if it+-- is ok. For it to be ok to overwrite it must either not already exist yet or+-- be a symlink to our target (in which case we can assume ownership).+--+targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private+                                -- binary that we would like to create+                    -> FilePath -- ^ The canonical path of the private binary.+                                -- Use 'canonicalizePath' to make this.+                    -> IO SymlinkStatus+targetOkToOverwrite symlink target = handleNotExist $ do+  status <- getSymbolicLinkStatus symlink+  if not (isSymbolicLink status)+    then return NotOurFile+    else do target' <- canonicalizePath symlink+            -- This relies on canonicalizePath handling symlinks+            if target == target'+              then return OkToOverwrite+              else return NotOurFile++  where+    handleNotExist action = catch action $ \ioexception ->+      -- If the target doesn't exist then there's no problem overwriting it!+      if isDoesNotExistError ioexception+        then return NotExists+        else ioError ioexception++data SymlinkStatus+   = NotExists     -- ^ The file doesn't exist so we can make a symlink.+   | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll+                   -- have to delete it first bemore we make a new symlink.+   | NotOurFile    -- ^ A file already exists and it is not one of our existing+                   -- symlinks (either because it is not a symlink or because+                   -- it points somewhere other than our managed space).+  deriving Show++-- | Take two canonical paths and produce a relative path to get from the first+-- to the second, even if it means adding @..@ path components.+--+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative a b = assert (isAbsolute a && isAbsolute b) $+  let as = splitPath a+      bs = splitPath b+      commonLen = length $ takeWhile id $ zipWith (==) as bs+   in joinPath $ [ ".." | _  <- drop commonLen as ]+              ++ [  b'  | b' <- drop commonLen bs ]++#endif
+ Distribution/Client/List.hs view
@@ -0,0 +1,528 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.List+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2008-2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+--+-- Search for and print information about packages+-----------------------------------------------------------------------------+module Distribution.Client.List (+  list, info+  ) where++import Distribution.Package+         ( PackageName(..), Package(..), packageName, packageVersion+         , Dependency(..), thisPackageVersion, depends, simplifyDependency )+import Distribution.ModuleName (ModuleName)+import Distribution.License (License)+import qualified Distribution.InstalledPackageInfo as Installed+import qualified Distribution.PackageDescription   as Available+import Distribution.PackageDescription+         ( Flag(..), FlagName(..) )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )++import Distribution.Simple.Compiler+        ( Compiler, PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Simple.Utils+        ( equating, comparing, die, notice )+import Distribution.Simple.Setup (fromFlag)+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Version+         ( Version(..), VersionRange, withinRange, anyVersion+         , intersectVersionRanges, simplifyVersionRange )+import Distribution.Verbosity (Verbosity)+import Distribution.Text+         ( Text(disp), display )++import Distribution.Client.Types+         ( AvailablePackage(..), Repo, AvailablePackageDb(..)+         , InstalledPackage(..) )+import Distribution.Client.Dependency.Types+         ( PackageConstraint(..) )+import Distribution.Client.Targets+         ( UserTarget, resolveUserTargets, PackageSpecifier(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), ListFlags(..), InfoFlags(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, getInstalledPackages )+import Distribution.Client.FetchUtils+         ( isFetched )++import Data.List+         ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )+import Data.Maybe+         ( listToMaybe, fromJust, fromMaybe, isJust )+import qualified Data.Map as Map+import Data.Tree as Tree+import Control.Monad+         ( MonadPlus(mplus), join )+import Control.Exception+         ( assert )+import Text.PrettyPrint.HughesPJ as Disp+import System.Directory+         ( doesDirectoryExist )+++-- |Show information about packages+list :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDBs repos comp conf listFlags pats = do++    installed   <- getInstalledPackages verbosity comp packageDBs conf+    availableDb <- getAvailablePackages verbosity repos+    let available  = packageIndex availableDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences availableDb))++        pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])]+        pkgsInfo+            -- gather info for all packages+          | null pats = mergePackages (PackageIndex.allPackages installed)+                                      (PackageIndex.allPackages available)++            -- gather info for packages matching search term+          | otherwise = mergePackages (matchingPackages installed)+                                      (matchingPackages available)++        matches :: [PackageDisplayInfo]+        matches = [ mergePackageInfo pref+                      installedPkgs availablePkgs selectedPkg False+                  | (pkgname, installedPkgs, availablePkgs) <- pkgsInfo+                  , not onlyInstalled || not (null installedPkgs)+                  , let pref        = prefs pkgname+                        selectedPkg = latestWithPref pref availablePkgs ]++    if simpleOutput+      then putStr $ unlines+             [ display (pkgName pkg) ++ " " ++ display version+             | pkg <- matches+             , version <- if onlyInstalled+                            then              installedVersions pkg+                            else nub . sort $ installedVersions pkg+                                           ++ availableVersions pkg ]+             -- Note: this only works because for 'list', one cannot currently+             -- specify any version constraints, so listing all installed+             -- and available ones works.+      else+        if null matches+            then notice verbosity "No matches found."+            else putStr $ unlines (map showPackageSummaryInfo matches)+  where+    onlyInstalled = fromFlag (listInstalled listFlags)+    simpleOutput  = fromFlag (listSimpleOutput listFlags)++    matchingPackages index =+      [ pkg+      | pat <- pats+      , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat+      , pkg <- pkgs ]++info :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> GlobalFlags+     -> InfoFlags+     -> [UserTarget]+     -> IO ()+info verbosity packageDBs repos comp conf+     globalFlags _listFlags userTargets = do++    installed     <- getInstalledPackages verbosity comp packageDBs conf+    availableDb   <- getAvailablePackages verbosity repos+    let available  = packageIndex availableDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences availableDb))++        -- Users may specify names of packages that are only installed, not+        -- just available source packages, so we must resolve targets using+        -- the combination of installed and available packages.+    let available' = PackageIndex.fromList+                   $ map packageId (PackageIndex.allPackages installed)+                  ++ map packageId (PackageIndex.allPackages available)+    pkgSpecifiers <- resolveUserTargets verbosity+                       globalFlags available' userTargets++    pkgsinfo      <- sequence+                       [ do pkginfo <- either die return $+                                         gatherPkgInfo prefs+                                           installed available pkgSpecifier+                            updateFileSystemPackageDetails pkginfo+                       | pkgSpecifier <- pkgSpecifiers ]++    putStr $ unlines (map showPackageDetailedInfo pkgsinfo)++  where+    gatherPkgInfo prefs installed available (NamedPackage name constraints)+      | null (selectedInstalledPkgs) && null (selectedAvailablePkgs)+      = Left $ "There is no available version of " ++ display name+            ++ " that satisfies "+            ++ display (simplifyVersionRange verConstraint)++      | otherwise+      = Right $ mergePackageInfo pref installedPkgs+                                 availablePkgs  selectedAvailablePkg+                                 showPkgVersion+      where+        pref           = prefs name+        installedPkgs  = PackageIndex.lookupPackageName installed name+        availablePkgs  = PackageIndex.lookupPackageName available name++        selectedInstalledPkgs = PackageIndex.lookupDependency installed+                                    (Dependency name verConstraint)+        selectedAvailablePkgs = PackageIndex.lookupDependency available+                                    (Dependency name verConstraint)+        selectedAvailablePkg  = latestWithPref pref selectedAvailablePkgs++                         -- display a specific package version if the user+                         -- supplied a non-trivial version constraint+        showPkgVersion = not (null verConstraints)+        verConstraint  = foldr intersectVersionRanges anyVersion verConstraints+        verConstraints = [ vr | PackageVersionConstraint _ vr <- constraints ]++    gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) =+        Right $ mergePackageInfo pref installedPkgs availablePkgs+                                 selectedPkg True+      where+        name          = packageName pkg+        pref          = prefs name+        installedPkgs = PackageIndex.lookupPackageName installed name+        availablePkgs = PackageIndex.lookupPackageName available name+        selectedPkg   = Just pkg+++-- | The info that we can display for each package. It is information per+-- package name and covers all installed and avilable versions.+--+data PackageDisplayInfo = PackageDisplayInfo {+    pkgName           :: PackageName,+    selectedVersion   :: Maybe Version,+    selectedAvailable :: Maybe AvailablePackage,+    installedVersions :: [Version],+    availableVersions :: [Version],+    preferredVersions :: VersionRange,+    homepage          :: String,+    bugReports        :: String,+    sourceRepo        :: String,+    synopsis          :: String,+    description       :: String,+    category          :: String,+    license           :: License,+    author            :: String,+    maintainer        :: String,+    dependencies      :: [Dependency],+    flags             :: [Flag],+    hasLib            :: Bool,+    hasExe            :: Bool,+    executables       :: [String],+    modules           :: [ModuleName],+    haddockHtml       :: FilePath,+    haveTarball       :: Bool+  }++showPackageSummaryInfo :: PackageDisplayInfo -> String+showPackageSummaryInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+     char '*' <+> disp (pkgName pkginfo)+     $+$+     (nest 4 $ vcat [+       maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs+     , text "Default available version:" <+>+       case selectedAvailable pkginfo of+         Nothing  -> text "[ Not available from any configured repository ]"+         Just pkg -> disp (packageVersion pkg)+     , text "Installed versions:" <+>+       case installedVersions pkginfo of+         []  | hasLib pkginfo -> text "[ Not installed ]"+             | otherwise      -> text "[ Unknown ]"+         versions             -> dispTopVersions 4+                                   (preferredVersions pkginfo) versions+     , maybeShow (homepage pkginfo) "Homepage:" text+     , text "License: " <+> text (display (license pkginfo))+     ])+     $+$ text ""+  where+    maybeShow [] _ _ = empty+    maybeShow l  s f = text s <+> (f l)++showPackageDetailedInfo :: PackageDisplayInfo -> String+showPackageDetailedInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+   char '*' <+> disp (pkgName pkginfo)+            <>  maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)+            <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')+            <>  parens pkgkind+   $+$+   (nest 4 $ vcat [+     entry "Synopsis"      synopsis     hideIfNull     reflowParagraphs+   , entry "Versions available" availableVersions+           (altText null "[ Not available from server ]")+           (dispTopVersions 9 (preferredVersions pkginfo))+   , entry "Versions installed" installedVersions+           (altText null (if hasLib pkginfo then "[ Not installed ]"+                                            else "[ Unknown ]"))+           (dispTopVersions 4 (preferredVersions pkginfo))+   , entry "Homepage"      homepage     orNotSpecified text+   , entry "Bug reports"   bugReports   orNotSpecified text+   , entry "Description"   description  hideIfNull     reflowParagraphs+   , entry "Category"      category     hideIfNull     text+   , entry "License"       license      alwaysShow     disp+   , entry "Author"        author       hideIfNull     reflowLines+   , entry "Maintainer"    maintainer   hideIfNull     reflowLines+   , entry "Source repo"   sourceRepo   orNotSpecified text+   , entry "Executables"   executables  hideIfNull     (commaSep text)+   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)+   , entry "Documentation" haddockHtml  showIfInstalled text+   , entry "Cached"        haveTarball  alwaysShow     dispYesNo+   , if not (hasLib pkginfo) then empty else+     text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+   ])+   $+$ text ""+  where+    entry fname field cond format = case cond (field pkginfo) of+      Nothing           -> label <+> format (field pkginfo)+      Just Nothing      -> empty+      Just (Just other) -> label <+> text other+      where+        label   = text fname <> char ':' <> padding+        padding = text (replicate (13 - length fname ) ' ')++    normal      = Nothing+    hide        = Just Nothing+    replace msg = Just (Just msg)++    alwaysShow = const normal+    hideIfNull v = if null v then hide else normal+    showIfInstalled v+      | not isInstalled = hide+      | null v          = replace "[ Not installed ]"+      | otherwise       = normal+    altText nul msg v = if nul v then replace msg else normal+    orNotSpecified = altText null "[ Not specified ]"++    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f+    dispFlag f = case flagName f of FlagName n -> text n+    dispYesNo True  = text "Yes"+    dispYesNo False = text "No"++    isInstalled = not (null (installedVersions pkginfo))+    hasExes = length (executables pkginfo) >= 2+    --TODO: exclude non-buildable exes+    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"+            | hasLib pkginfo && hasExe pkginfo = text "program and library"+            | hasLib pkginfo                   = text "library"+            | hasExes                          = text "programs"+            | hasExe pkginfo                   = text "program"+            | otherwise                        = empty+++reflowParagraphs :: String -> Doc+reflowParagraphs =+    vcat+  . intersperse (text "")                    -- re-insert blank lines+  . map (fsep . map text . concatMap words)  -- reflow paragraphs+  . filter (/= [""])+  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines+  . lines++reflowLines :: String -> Doc+reflowLines = vcat . map text . lines++-- | We get the 'PackageDisplayInfo' by combining the info for the installed+-- and available versions of a package.+--+-- * We're building info about a various versions of a single named package so+-- the input package info records are all supposed to refer to the same+-- package name.+--+mergePackageInfo :: VersionRange+                 -> [InstalledPackage]+                 -> [AvailablePackage]+                 -> Maybe AvailablePackage+                 -> Bool+                 -> PackageDisplayInfo+mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer =+  assert (length installedPkgs + length availablePkgs > 0) $+  PackageDisplayInfo {+    pkgName           = combine packageName available+                                packageName installed,+    selectedVersion   = if showVer then fmap packageVersion selectedPkg+                                   else Nothing,+    selectedAvailable = availableSelected,+    installedVersions = map packageVersion installedPkgs,+    availableVersions = map packageVersion availablePkgs,+    preferredVersions = versionPref,++    license      = combine Available.license    available+                           Installed.license    installed,+    maintainer   = combine Available.maintainer available+                           Installed.maintainer installed,+    author       = combine Available.author     available+                           Installed.author     installed,+    homepage     = combine Available.homepage   available+                           Installed.homepage   installed,+    bugReports   = maybe "" Available.bugReports available,+    sourceRepo   = fromMaybe "" . join+                 . fmap (uncons Nothing Available.repoLocation+                       . sortBy (comparing Available.repoKind)+                       . Available.sourceRepos)+                 $ available,+                    --TODO: installed package info is missing synopsis+    synopsis     = maybe "" Available.synopsis   available,+    description  = combine Available.description available+                           Installed.description installed,+    category     = combine Available.category    available+                           Installed.category    installed,+    flags        = maybe [] Available.genPackageFlags availableGeneric,+    hasLib       = isJust installed+                || fromMaybe False+                   (fmap (isJust . Available.condLibrary) availableGeneric),+    hasExe       = fromMaybe False+                   (fmap (not . null . Available.condExecutables) availableGeneric),+    executables  = map fst (maybe [] Available.condExecutables availableGeneric),+    modules      = combine Installed.exposedModules installed+                           (maybe [] Available.exposedModules+                                   . Available.library) available,+    dependencies = map simplifyDependency+                 $ combine Available.buildDepends available+                           (map thisPackageVersion . depends) installed',+    haddockHtml  = fromMaybe "" . join+                 . fmap (listToMaybe . Installed.haddockHTMLs)+                 $ installed,+    haveTarball  = False+  }+  where+    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)+    installed'       = latestWithPref versionPref installedPkgs+    installed        = fmap (\(InstalledPackage p _) -> p) installed'++    availableSelected+      | isJust selectedPkg = selectedPkg+      | otherwise          = latestWithPref versionPref availablePkgs+    availableGeneric = fmap packageDescription availableSelected+    available        = fmap flattenPackageDescription availableGeneric++    uncons :: b -> (a -> b) -> [a] -> b+    uncons z _ []    = z+    uncons _ f (x:_) = f x+++-- | Not all the info is pure. We have to check if the docs really are+-- installed, because the registered package info lies. Similarly we have to+-- check if the tarball has indeed been fetched.+--+updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo+updateFileSystemPackageDetails pkginfo = do+  fetched   <- maybe (return False) (isFetched . packageSource)+                     (selectedAvailable pkginfo)+  docsExist <- doesDirectoryExist (haddockHtml pkginfo)+  return pkginfo {+    haveTarball = fetched,+    haddockHtml = if docsExist then haddockHtml pkginfo else ""+  }++latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg+latestWithPref _    []   = Nothing+latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)+  where+    prefThenVersion pkg = let ver = packageVersion pkg+                           in (withinRange ver pref, ver)+++-- | Rearrange installed and available packages into groups referring to the+-- same package by name. In the result pairs, the lists are guaranteed to not+-- both be empty.+--+mergePackages :: [InstalledPackage]+              -> [AvailablePackage]+              -> [( PackageName+                  , [InstalledPackage]+                  , [AvailablePackage] )]+mergePackages installed available =+    map collect+  $ mergeBy (\i a -> fst i `compare` fst a)+            (groupOn packageName installed)+            (groupOn packageName available)+  where+    collect (OnlyInLeft  (name,is)         ) = (name, is, [])+    collect (    InBoth  (_,is)   (name,as)) = (name, is, as)+    collect (OnlyInRight          (name,as)) = (name, [], as)++groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]+groupOn key = map (\xs -> (key (head xs), xs))+            . groupBy (equating key)+            . sortBy (comparing key)++dispTopVersions :: Int -> VersionRange -> [Version] -> Doc+dispTopVersions n pref vs =+         (Disp.fsep . Disp.punctuate (Disp.char ',')+        . map (\ver -> if ispref ver then disp ver else parens (disp ver))+        . sort . take n . interestingVersions ispref+        $ vs)+    <+> trailingMessage++  where+    ispref ver = withinRange ver pref+    extra = length vs - n+    trailingMessage+      | extra <= 0 = Disp.empty+      | otherwise  = Disp.parens $ Disp.text "and"+                               <+> Disp.int (length vs - n)+                               <+> if extra == 1 then Disp.text "other"+                                                 else Disp.text "others"++-- | Reorder a bunch of versions to put the most interesting / significant+-- versions first. A preferred version range is taken into account.+--+-- This may be used in a user interface to select a small number of versions+-- to present to the user, e.g.+--+-- > let selectVersions = sort . take 5 . interestingVersions pref+--+interestingVersions :: (Version -> Bool) -> [Version] -> [Version]+interestingVersions pref =+      map ((\ns -> Version ns []) . fst) . filter snd+    . concat  . Tree.levels+    . swizzleTree+    . reorderTree (\(Node (v,_) _) -> pref (Version v []))+    . reverseTree+    . mkTree+    . map versionBranch++  where+    swizzleTree = unfoldTree (spine [])+      where+        spine ts' (Node x [])     = (x, ts')+        spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t++    reorderTree _ (Node x []) = Node x []+    reorderTree p (Node x ts) = Node x (ts' ++ ts'')+      where+        (ts',ts'') = partition p (map (reorderTree p) ts)++    reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))++    mkTree xs = unfoldTree step (False, [], xs)+      where+        step (node,ns,vs) =+          ( (reverse ns, node)+          , [ (any null vs', n:ns, filter (not . null) vs')+            | (n, vs') <- groups vs ]+          )+        groups = map (\g -> (head (head g), map tail g))+               . groupBy (equating head)
+ Distribution/Client/PackageIndex.hs view
@@ -0,0 +1,478 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages.+--+module Distribution.Client.PackageIndex (+  -- * Package index data type+  PackageIndex,++  -- * Creating an index+  fromList,++  -- * Updates+  merge,+  insert,+  deletePackageName,+  deletePackageId,+  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  lookupPackageName,+  lookupPackageId,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,++  -- ** Special queries+  brokenPackages,+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,+  dependencyInconsistencies,+  dependencyCycles,+  dependencyGraph,+  ) where++import Prelude hiding (lookup)+import Control.Exception (assert)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Tree  as Tree+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Data.Array ((!))+import Data.List (groupBy, sortBy, nub, isInfixOf)+import Data.Monoid (Monoid(..))+import Data.Maybe (isNothing, fromMaybe)++import Distribution.Package+         ( PackageName(..), PackageIdentifier(..)+         , Package(..), packageName, packageVersion+         , Dependency(Dependency), PackageFixedDeps(..) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.Simple.Utils (lowercase, equating, comparing)+++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- It can be searched effeciently by package name and version.+--+newtype Package pkg => PackageIndex pkg = PackageIndex+  -- This index package names to all the package records matching that package+  -- name case-sensitively. It includes all versions.+  --+  -- This allows us to find all versions satisfying a dependency.+  -- Most queries are a map lookup followed by a linear scan of the bucket.+  --+  (Map PackageName [pkg])++  deriving (Show, Read)++instance Package pkg => Monoid (PackageIndex pkg) where+  mempty  = PackageIndex (Map.empty)+  mappend = merge+  --save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = foldr1 mappend xs++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+  where+    goodBucket _    [] = False+    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0+      where+        check pkgid []          = packageName pkgid == name+        check pkgid (pkg':pkgs) = packageName pkgid == name+                               && pkgid < pkgid'+                               && check pkgid' pkgs+          where pkgid' = packageId pkg'++--+-- * Internal helpers+--++mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg+mkPackageIndex index = assert (invariant (PackageIndex index))+                                         (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-sensitively.+--+lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m++--+-- * Construction+--++-- | Build an index out of a bunch of packages.+--+-- If there are duplicates, later ones mask earlier ones.+--+fromList :: Package pkg => [pkg] -> PackageIndex pkg+fromList pkgs = mkPackageIndex+              . Map.map fixBucket+              . Map.fromListWith (++)+              $ [ (packageName pkg, [pkg])+                | pkg <- pkgs ]+  where+    fixBucket = -- out of groups of duplicates, later ones mask earlier ones+                -- but Map.fromListWith (++) constructs groups in reverse order+                map head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . groupBy (\a b -> EQ == comparing packageId a b)+                -- relies on sortBy being a stable sort so we+                -- can pick consistently among duplicates+              . sortBy (comparing packageId)++--+-- * Updates+--++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+  assert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets []     ys     = ys+mergeBuckets xs     []     = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+      case packageId x `compare` packageId y of+        GT -> y : mergeBuckets xs  ys'+        EQ -> y : mergeBuckets xs' ys'+        LT -> x : mergeBuckets xs' ys++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg+insert pkg (PackageIndex index) = mkPackageIndex $+  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertNoDup []                = [pkg]+    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+      LT -> pkg  : pkgs+      EQ -> pkg  : pkgs'+      GT -> pkg' : insertNoDup pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+  Map.update filterBucket name index+  where+    filterBucket = deleteEmptyBucket+                 . filter (not . p)+    deleteEmptyBucket []        = Nothing+    deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg+deletePackageId pkgid =+  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg+deletePackageName name =+  delete name (\pkg -> packageName pkg == name)++-- | Removes all packages satisfying this dependency from the index.+--+deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg+deleteDependency (Dependency name verstionRange) =+  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)++--+-- * Bulk queries+--++-- | Get all the packages from the index.+--+allPackages :: Package pkg => PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) = Map.elems m++--+-- * Lookups+--++-- | Does a lookup by package id (name & version).+--+-- Since multiple package DBs mask each other case-sensitively by package name,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg+lookupPackageId index pkgid =+  case [ pkg | pkg <- lookup index (packageName pkgid)+             , packageId pkg == pkgid ] of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookupPackageName index name =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name ]++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]+lookupDependency index (Dependency name versionRange) =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name+        , packageVersion pkg `withinRange` versionRange ]++--+-- * Case insensitive name lookups+--++-- | Does a case-insensitive search by package name.+--+-- If there is only one package that compares case-insentiviely to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insentiviely but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insentiviely and none match exactly then we+-- have an ambiguous result, and we get back all the versions of all the+-- packages. The list of ambiguous results is split by exact package name. So+-- it is a non-empty list of non-empty lists.+--+searchByName :: Package pkg => PackageIndex pkg+             -> String -> [(PackageName, [pkg])]+searchByName (PackageIndex m) name =+    [ pkgs+    | pkgs@(PackageName name',_) <- Map.toList m+    , lowercase name' == lname ]+  where+    lname = lowercase name++data SearchResult a = None | Unambiguous a | Ambiguous [a]++-- | Does a case-insensitive substring search by package name.+--+-- That is, all packages that contain the given string in their name.+--+searchByNameSubstring :: Package pkg => PackageIndex pkg+                      -> String -> [(PackageName, [pkg])]+searchByNameSubstring (PackageIndex m) searchterm =+    [ pkgs+    | pkgs@(PackageName name, _) <- Map.toList m+    , lsearchterm `isInfixOf` lowercase name ]+  where+    lsearchterm = lowercase searchterm++--+-- * Special queries+--++-- | All packages that have dependencies that are not in the index.+--+-- Returns such packages along with the dependencies that they're missing.+--+brokenPackages :: PackageFixedDeps pkg+               => PackageIndex pkg+               -> [(pkg, [PackageIdentifier])]+brokenPackages index =+  [ (pkg, missing)+  | pkg  <- allPackages index+  , let missing = [ pkg' | pkg' <- depends pkg+                         , isNothing (lookupPackageId index pkg') ]+  , not (null missing) ]++-- | Tries to take the transative closure of the package dependencies.+--+-- If the transative closure is complete then it returns that subset of the+-- index. Otherwise it returns the broken packages as in 'brokenPackages'.+--+-- * Note that if the result is @Right []@ it is because at least one of+-- the original given 'PackageIdentifier's do not occur in the index.+--+dependencyClosure :: PackageFixedDeps pkg+                  => PackageIndex pkg+                  -> [PackageIdentifier]+                  -> Either (PackageIndex pkg)+                            [(pkg, [PackageIdentifier])]+dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of+  (completed, []) -> Left completed+  (completed, _)  -> Right (brokenPackages completed)+  where+    closure completed failed []             = (completed, failed)+    closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of+      Nothing   -> closure completed (pkgid:failed) pkgids+      Just pkg  -> case lookupPackageId completed (packageId pkg) of+        Just _  -> closure completed  failed pkgids+        Nothing -> closure completed' failed pkgids'+          where completed' = insert pkg completed+                pkgids'    = depends pkg ++ pkgids++-- | Takes the transative closure of the packages reverse dependencies.+--+-- * The given 'PackageIdentifier's must be in the index.+--+reverseDependencyClosure :: PackageFixedDeps pkg+                         => PackageIndex pkg+                         -> [PackageIdentifier]+                         -> [pkg]+reverseDependencyClosure index =+    map vertexToPkg+  . concatMap Tree.flatten+  . Graph.dfs reverseDepGraph+  . map (fromMaybe noSuchPkgId . pkgIdToVertex)++  where+    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index+    reverseDepGraph = Graph.transposeG depGraph+    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"++topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]+topologicalOrder index = map toPkgId+                       . Graph.topSort+                       $ graph+  where (graph, toPkgId, _) = dependencyGraph index++reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]+reverseTopologicalOrder index = map toPkgId+                              . Graph.topSort+                              . Graph.transposeG+                              $ graph+  where (graph, toPkgId, _) = dependencyGraph index++-- | Given a package index where we assume we want to use all the packages+-- (use 'dependencyClosure' if you need to get such a index subset) find out+-- if the dependencies within it use consistent versions of each package.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- Each element in the result is a package name along with the packages that+-- depend on it and the versions they require. These are guaranteed to be+-- distinct.+--+dependencyInconsistencies :: PackageFixedDeps pkg+                          => PackageIndex pkg+                          -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies index =+  [ (name, inconsistencies)+  | (name, uses) <- Map.toList inverseIndex+  , let inconsistencies = duplicatesBy uses+        versions = map snd inconsistencies+  , reallyIsInconsistent name (nub versions) ]++  where inverseIndex = Map.fromListWith (++)+          [ (packageName dep, [(packageId pkg, packageVersion dep)])+          | pkg <- allPackages index+          , dep <- depends pkg ]++        duplicatesBy = (\groups -> if length groups == 1+                                     then []+                                     else concat groups)+                     . groupBy (equating snd)+                     . sortBy (comparing snd)++        reallyIsInconsistent :: PackageName -> [Version] -> Bool+        reallyIsInconsistent _    []       = False+        reallyIsInconsistent name [v1, v2] =+          case (mpkg1, mpkg2) of+            (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2+                                   && pkgid2 `notElem` depends pkg1+            _ -> True+          where+            pkgid1 = PackageIdentifier name v1+            pkgid2 = PackageIdentifier name v2+            mpkg1 = lookupPackageId index pkgid1+            mpkg2 = lookupPackageId index pkgid2++        reallyIsInconsistent _ _ = True++-- | Find if there are any cycles in the dependency graph. If there are no+-- cycles the result is @[]@.+--+-- This actually computes the strongly connected components. So it gives us a+-- list of groups of packages where within each group they all depend on each+-- other, directly or indirectly.+--+dependencyCycles :: PackageFixedDeps pkg+                 => PackageIndex pkg+                 -> [[pkg]]+dependencyCycles index =+  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  where+    adjacencyList = [ (pkg, packageId pkg, depends pkg)+                    | pkg <- allPackages index ]++-- | Builds a graph of the package dependencies.+--+-- Dependencies on other packages that are not in the index are discarded.+-- You can check if there are any such dependencies with 'brokenPackages'.+--+dependencyGraph :: PackageFixedDeps pkg+                => PackageIndex pkg+                -> (Graph.Graph,+                    Graph.Vertex -> pkg,+                    PackageIdentifier -> Maybe Graph.Vertex)+dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)+  where+    graph = Array.listArray bounds+              [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]+              | pkg <- pkgs ]+    vertexToPkg vertex = pkgTable ! vertex+    pkgIdToVertex = binarySearch 0 topBound++    pkgTable   = Array.listArray bounds pkgs+    pkgIdTable = Array.listArray bounds (map packageId pkgs)+    pkgs = sortBy (comparing packageId) (allPackages index)+    topBound = length pkgs - 1+    bounds = (0, topBound)++    binarySearch a b key+      | a > b     = Nothing+      | otherwise = case compare key (pkgIdTable ! mid) of+          LT -> binarySearch a (mid-1) key+          EQ -> Just mid+          GT -> binarySearch (mid+1) b key+      where mid = (a + b) `div` 2
+ Distribution/Client/PackageUtils.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.PackageUtils+-- Copyright   :  (c) Duncan Coutts 2010+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Various package description utils that should be in the Cabal lib+-----------------------------------------------------------------------------+module Distribution.Client.PackageUtils (+    externalBuildDepends,+  ) where++import Distribution.Package+         ( packageVersion, packageName, Dependency(..) )+import Distribution.PackageDescription+         ( PackageDescription(..) )+import Distribution.Version+         ( withinRange )++-- | The list of dependencies that refer to external packages+-- rather than internal package components.+--+externalBuildDepends :: PackageDescription -> [Dependency]+externalBuildDepends pkg = filter (not . internal) (buildDepends pkg)+  where+    -- True if this dependency is an internal one (depends on a library+    -- defined in the same package).+    internal (Dependency depName versionRange) =+            depName == packageName pkg &&+            packageVersion pkg `withinRange` versionRange
+ Distribution/Client/Setup.hs view
@@ -0,0 +1,1009 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Setup+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Setup+    ( globalCommand, GlobalFlags(..), globalRepos+    , configureCommand, ConfigFlags(..), filterConfigureFlags+    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags+                        , configureExOptions+    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , listCommand, ListFlags(..)+    , updateCommand+    , upgradeCommand+    , infoCommand, InfoFlags(..)+    , fetchCommand, FetchFlags(..)+    , checkCommand+    , uploadCommand, UploadFlags(..)+    , reportCommand, ReportFlags(..)+    , unpackCommand, UnpackFlags(..)+    , initCommand, IT.InitFlags(..)++    , parsePackageArgs+    --TODO: stop exporting these:+    , showRepo+    , parseRepo+    ) where++import Distribution.Client.Types+         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import qualified Distribution.Client.Init.Types as IT+         ( InitFlags(..), PackageType(..) )++import Distribution.Simple.Program+         ( defaultProgramConfiguration )+import Distribution.Simple.Command hiding (boolOpt)+import qualified Distribution.Simple.Command as Command+import qualified Distribution.Simple.Setup as Cabal+         ( configureCommand )+import Distribution.Simple.Setup+         ( ConfigFlags(..) )+import Distribution.Simple.Setup+         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe+         , optionVerbosity, trueArg, falseArg )+import Distribution.Simple.InstallDirs+         ( PathTemplate, toPathTemplate, fromPathTemplate )+import Distribution.Version+         ( Version(Version), anyVersion, thisVersion )+import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+import Distribution.Text+         ( Text(parse), display )+import Distribution.ReadE+         ( readP_to_E, succeedReadE )+import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText )++import Data.Char+         ( isSpace, isAlphaNum )+import Data.Maybe+         ( listToMaybe, maybeToList, fromMaybe )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( liftM )+import System.FilePath+         ( (</>) )+import Network.URI+         ( parseAbsoluteURI, uriToString )++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+    globalVersion        :: Flag Bool,+    globalNumericVersion :: Flag Bool,+    globalConfigFile     :: Flag FilePath,+    globalRemoteRepos    :: [RemoteRepo],     -- ^Available Hackage servers.+    globalCacheDir       :: Flag FilePath,+    globalLocalRepos     :: [FilePath],+    globalLogsDir        :: Flag FilePath,+    globalWorldFile      :: Flag FilePath+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion        = Flag False,+    globalNumericVersion = Flag False,+    globalConfigFile     = mempty,+    globalRemoteRepos    = [],+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty,+    globalLogsDir        = mempty,+    globalWorldFile      = mempty+  }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    commandUsage        = \_ ->+         "This program is the command line interface "+           ++ "to the Haskell Cabal infrastructure.\n"+      ++ "See http://www.haskell.org/cabal/ for more information.\n",+    commandDescription  = Just $ \pname ->+         "For more information about a command use:\n"+      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      ++ "To install Cabal packages from hackage use:\n"+      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"+      ++ "Occasionally you need to update the list of available packages:\n"+      ++ "  " ++ pname ++ " update\n",+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions      = \showOrParseArgs ->+      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)+      [option ['V'] ["version"]+         "Print version information"+         globalVersion (\v flags -> flags { globalVersion = v })+         trueArg++      ,option [] ["numeric-version"]+         "Print just the version number"+         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })+         trueArg++      ,option [] ["config-file"]+         "Set an alternate location for the config file"+         globalConfigFile (\v flags -> flags { globalConfigFile = v })+         (reqArgFlag "FILE")++      ,option [] ["remote-repo"]+         "The name and url for a remote repository"+         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })+         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))++      ,option [] ["remote-repo-cache"]+         "The location where downloads from all remote repos are cached"+         globalCacheDir (\v flags -> flags { globalCacheDir = v })+         (reqArgFlag "DIR")++      ,option [] ["local-repo"]+         "The location of a local repository"+         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })+         (reqArg' "DIR" (\x -> [x]) id)++      ,option [] ["logs-dir"]+         "The location to put log files"+         globalLogsDir (\v flags -> flags { globalLogsDir = v })+         (reqArgFlag "DIR")++      ,option [] ["world-file"]+         "The location of the world file"+         globalWorldFile (\v flags -> flags { globalWorldFile = v })+         (reqArgFlag "FILE")+      ]+  }++instance Monoid GlobalFlags where+  mempty = GlobalFlags {+    globalVersion        = mempty,+    globalNumericVersion = mempty,+    globalConfigFile     = mempty,+    globalRemoteRepos    = mempty,+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty,+    globalLogsDir        = mempty,+    globalWorldFile      = mempty+  }+  mappend a b = GlobalFlags {+    globalVersion        = combine globalVersion,+    globalNumericVersion = combine globalNumericVersion,+    globalConfigFile     = combine globalConfigFile,+    globalRemoteRepos    = combine globalRemoteRepos,+    globalCacheDir       = combine globalCacheDir,+    globalLocalRepos     = combine globalLocalRepos,+    globalLogsDir        = combine globalLogsDir,+    globalWorldFile      = combine globalWorldFile+  }+    where combine field = field a `mappend` field b++globalRepos :: GlobalFlags -> [Repo]+globalRepos globalFlags = remoteRepos ++ localRepos+  where+    remoteRepos =+      [ Repo (Left remote) cacheDir+      | remote <- globalRemoteRepos globalFlags+      , let cacheDir = fromFlag (globalCacheDir globalFlags)+                   </> remoteRepoName remote ]+    localRepos =+      [ Repo (Right LocalRepo) local+      | local <- globalLocalRepos globalFlags ]++-- ------------------------------------------------------------+-- * Config flags+-- ------------------------------------------------------------++configureCommand :: CommandUI ConfigFlags+configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {+    commandDefaultFlags = mempty+  }++configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions = commandOptions configureCommand++filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags+filterConfigureFlags flags cabalLibVersion+  | cabalLibVersion >= Version [1,3,10] [] = flags+    -- older Cabal does not grok the constraints flag:+  | otherwise = flags { configConstraints = [] }+++-- ------------------------------------------------------------+-- * Config extra flags+-- ------------------------------------------------------------++-- | cabal configure takes some extra flags beyond runghc Setup configure+--+data ConfigExFlags = ConfigExFlags {+    configCabalVersion :: Flag Version,+    configPreferences  :: [Dependency]+  }++defaultConfigExFlags :: ConfigExFlags+defaultConfigExFlags = mempty++configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)+configureExCommand = configureCommand {+    commandDefaultFlags = (mempty, defaultConfigExFlags),+    commandOptions      = \showOrParseArgs ->+         liftOptions fst setFst (configureOptions   showOrParseArgs)+      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs =+  [ option [] ["cabal-lib-version"]+      ("Select which version of the Cabal lib to use to build packages "+      ++ "(useful for testing).")+      configCabalVersion (\v flags -> flags { configCabalVersion = v })+      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)+                                    (fmap toFlag parse))+                        (map display . flagToList))++  , option [] ["preference"]+      "Specify preferences (soft constraints) on the version of a package"+      configPreferences (\v flags -> flags { configPreferences = v })+      (reqArg "DEPENDENCY"+        (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))+                                        (map (\x -> display x)))+  ]++instance Monoid ConfigExFlags where+  mempty = ConfigExFlags {+    configCabalVersion = mempty,+    configPreferences  = mempty+  }+  mappend a b = ConfigExFlags {+    configCabalVersion = combine configCabalVersion,+    configPreferences  = combine configPreferences+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Fetch command+-- ------------------------------------------------------------++data FetchFlags = FetchFlags {+--    fetchOutput    :: Flag FilePath,+      fetchDeps      :: Flag Bool,+      fetchDryRun    :: Flag Bool,+      fetchVerbosity :: Flag Verbosity+    }++defaultFetchFlags :: FetchFlags+defaultFetchFlags = FetchFlags {+--  fetchOutput    = mempty,+    fetchDeps      = toFlag True,+    fetchDryRun    = toFlag False,+    fetchVerbosity = toFlag normal+   }++fetchCommand :: CommandUI FetchFlags+fetchCommand = CommandUI {+    commandName         = "fetch",+    commandSynopsis     = "Downloads packages for later installation.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "fetch",+    commandDefaultFlags = defaultFetchFlags,+    commandOptions      = \_ -> [+         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })++--     , option "o" ["output"]+--         "Put the package(s) somewhere specific rather than the usual cache."+--         fetchOutput (\v flags -> flags { fetchOutput = v })+--         (reqArgFlag "PATH")++       , option [] ["dependencies", "deps"]+           "Resolve and fetch dependencies (default)"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           trueArg++       , option [] ["no-dependencies", "no-deps"]+           "Ignore dependencies"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           falseArg++       , option [] ["dry-run"]+           "Do not install anything, only print what would be installed."+           fetchDryRun (\v flags -> flags { fetchDryRun = v })+           trueArg+       ]+  }++-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------++updateCommand  :: CommandUI (Flag Verbosity)+updateCommand = CommandUI {+    commandName         = "update",+    commandSynopsis     = "Updates list of known packages",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "update",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeCommand = configureCommand {+    commandName         = "upgrade",+    commandSynopsis     = "(command disabled, use install instead)",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "upgrade",+    commandDefaultFlags = (mempty, mempty, mempty),+    commandOptions      = commandOptions installCommand+  }++{-+cleanCommand  :: CommandUI ()+cleanCommand = makeCommand name shortDesc longDesc emptyFlags options+  where+    name       = "clean"+    shortDesc  = "Removes downloaded files"+    longDesc   = Nothing+    emptyFlags = ()+    options _  = []+-}++checkCommand  :: CommandUI (Flag Verbosity)+checkCommand = CommandUI {+    commandName         = "check",+    commandSynopsis     = "Check the package for common mistakes",+    commandDescription  = Nothing,+    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }++-- ------------------------------------------------------------+-- * Report flags+-- ------------------------------------------------------------++data ReportFlags = ReportFlags {+    reportUsername  :: Flag Username,+    reportPassword  :: Flag Password,+    reportVerbosity :: Flag Verbosity+  }++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags {+    reportUsername  = mempty,+    reportPassword  = mempty,+    reportVerbosity = toFlag normal+  }++reportCommand :: CommandUI ReportFlags+reportCommand = CommandUI {+    commandName         = "report",+    commandSynopsis     = "Upload build reports to a remote server.",+    commandDescription  = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"+      ++ "Flags for upload:",+    commandDefaultFlags = defaultReportFlags,+    commandOptions      = \_ ->+      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })++      ,option ['u'] ["username"]+        "Hackage username."+        reportUsername (\v flags -> flags { reportUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        reportPassword (\v flags -> flags { reportPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid ReportFlags where+  mempty = ReportFlags {+    reportUsername  = mempty,+    reportPassword  = mempty,+    reportVerbosity = mempty+  }+  mappend a b = ReportFlags {+    reportUsername  = combine reportUsername,+    reportPassword  = combine reportPassword,+    reportVerbosity = combine reportVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Unpack flags+-- ------------------------------------------------------------++data UnpackFlags = UnpackFlags {+      unpackDestDir :: Flag FilePath,+      unpackVerbosity :: Flag Verbosity+    }++defaultUnpackFlags :: UnpackFlags+defaultUnpackFlags = UnpackFlags {+    unpackDestDir = mempty,+    unpackVerbosity = toFlag normal+   }++unpackCommand :: CommandUI UnpackFlags+unpackCommand = CommandUI {+    commandName         = "unpack",+    commandSynopsis     = "Unpacks packages for user inspection.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "unpack",+    commandDefaultFlags = mempty,+    commandOptions      = \_ -> [+        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })++       ,option "d" ["destdir"]+         "where to unpack the packages, defaults to the current directory."+         unpackDestDir (\v flags -> flags { unpackDestDir = v })+         (reqArgFlag "PATH")+       ]+  }++instance Monoid UnpackFlags where+  mempty = defaultUnpackFlags+  mappend a b = UnpackFlags {+     unpackDestDir = combine unpackDestDir+    ,unpackVerbosity = combine unpackVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * List flags+-- ------------------------------------------------------------++data ListFlags = ListFlags {+    listInstalled :: Flag Bool,+    listSimpleOutput :: Flag Bool,+    listVerbosity :: Flag Verbosity+  }++defaultListFlags :: ListFlags+defaultListFlags = ListFlags {+    listInstalled = Flag False,+    listSimpleOutput = Flag False,+    listVerbosity = toFlag normal+  }++listCommand  :: CommandUI ListFlags+listCommand = CommandUI {+    commandName         = "list",+    commandSynopsis     = "List packages matching a search string.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "list",+    commandDefaultFlags = defaultListFlags,+    commandOptions      = \_ -> [+        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })++        , option [] ["installed"]+            "Only print installed packages"+            listInstalled (\v flags -> flags { listInstalled = v })+            trueArg++        , option [] ["simple-output"]+            "Print in a easy-to-parse format"+            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+            trueArg++        ]+  }++instance Monoid ListFlags where+  mempty = defaultListFlags+  mappend a b = ListFlags {+    listInstalled = combine listInstalled,+    listSimpleOutput = combine listSimpleOutput,+    listVerbosity = combine listVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Info flags+-- ------------------------------------------------------------++data InfoFlags = InfoFlags {+    infoVerbosity :: Flag Verbosity+  }++defaultInfoFlags :: InfoFlags+defaultInfoFlags = InfoFlags {+    infoVerbosity = toFlag normal+  }++infoCommand  :: CommandUI InfoFlags+infoCommand = CommandUI {+    commandName         = "info",+    commandSynopsis     = "Display detailed information about a particular package.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "info",+    commandDefaultFlags = defaultInfoFlags,+    commandOptions      = \_ -> [+        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })+        ]+  }++instance Monoid InfoFlags where+  mempty = defaultInfoFlags+  mappend a b = InfoFlags {+    infoVerbosity = combine infoVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Install flags+-- ------------------------------------------------------------++-- | Install takes the same flags as configure along with a few extras.+--+data InstallFlags = InstallFlags {+    installDocumentation:: Flag Bool,+    installHaddockIndex :: Flag PathTemplate,+    installDryRun       :: Flag Bool,+    installReinstall    :: Flag Bool,+    installUpgradeDeps  :: Flag Bool,+    installOnly         :: Flag Bool,+    installOnlyDeps     :: Flag Bool,+    installRootCmd      :: Flag String,+    installSummaryFile  :: [PathTemplate],+    installLogFile      :: Flag PathTemplate,+    installBuildReports :: Flag ReportLevel,+    installSymlinkBinDir:: Flag FilePath,+    installOneShot      :: Flag Bool+  }++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+    installDocumentation= Flag False,+    installHaddockIndex = Flag docIndexFile,+    installDryRun       = Flag False,+    installReinstall    = Flag False,+    installUpgradeDeps  = Flag False,+    installOnly         = Flag False,+    installOnlyDeps     = Flag False,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = Flag NoReports,+    installSymlinkBinDir= mempty,+    installOneShot      = Flag False+  }+  where+    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")++installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+installCommand = CommandUI {+  commandName         = "install",+  commandSynopsis     = "Installs a list of packages.",+  commandUsage        = usagePackages "install",+  commandDescription  = Just $ \pname ->+    let original = case commandDescription configureCommand of+          Just desc -> desc pname ++ "\n"+          Nothing   -> ""+     in original+     ++ "Examples:\n"+     ++ "  " ++ pname ++ " install                 "+     ++ "    Package in the current directory\n"+     ++ "  " ++ pname ++ " install foo             "+     ++ "    Package from the hackage server\n"+     ++ "  " ++ pname ++ " install foo-1.0         "+     ++ "    Specific version of a package\n"+     ++ "  " ++ pname ++ " install 'foo < 2'       "+     ++ "    Constrained package version\n",+  commandDefaultFlags = (mempty, mempty, mempty),+  commandOptions      = \showOrParseArgs ->+       liftOptions get1 set1 (configureOptions   showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)+    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)+  }+  where+    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)+    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)+    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)++installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]+installOptions showOrParseArgs =+      [ option "" ["documentation"]+          "building of documentation"+          installDocumentation (\v flags -> flags { installDocumentation = v })+          (boolOpt [] [])++      , option [] ["doc-index-file"]+          "A central index of haddock API documentation (template cannot use $pkgid)"+          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["dry-run"]+          "Do not install anything, only print what would be installed."+          installDryRun (\v flags -> flags { installDryRun = v })+          trueArg++      , option [] ["reinstall"]+          "Install even if it means installing the same version again."+          installReinstall (\v flags -> flags { installReinstall = v })+          trueArg++      , option [] ["upgrade-dependencies"]+          "Pick the latest version for all dependencies, rather than trying to pick an installed version."+          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })+          trueArg+++      , option [] ["only-dependencies"]+          "Install only the dependencies necessary to build the given packages"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          trueArg+++      , option [] ["root-cmd"]+          "Command used to gain root privileges, when installing with --global."+          installRootCmd (\v flags -> flags { installRootCmd = v })+          (reqArg' "COMMAND" toFlag flagToList)++      , option [] ["symlink-bindir"]+          "Add symlinks to installed executables into this directory."+           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })+           (reqArgFlag "DIR")++      , option [] ["build-summary"]+          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"+          installSummaryFile (\v flags -> flags { installSummaryFile = v })+          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))++      , option [] ["build-log"]+          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"+          installLogFile (\v flags -> flags { installLogFile = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["remote-build-reporting"]+          "Generate build reports to send to a remote server (none, anonymous or detailed)."+          installBuildReports (\v flags -> flags { installBuildReports = v })+          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "+                                            ++ "'anonymous' or 'detailed'")+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option [] ["one-shot"]+          "Do not record the packages in the world file."+          installOneShot (\v flags -> flags { installOneShot = v })+          trueArg+      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids+          ParseArgs ->+            option [] ["only"]+              "Only installs the package in the current directory."+              installOnly (\v flags -> flags { installOnly = v })+              trueArg+             : []+          _ -> []++instance Monoid InstallFlags where+  mempty = InstallFlags {+    installDocumentation= mempty,+    installHaddockIndex = mempty,+    installDryRun       = mempty,+    installReinstall    = mempty,+    installUpgradeDeps  = mempty,+    installOnly         = mempty,+    installOnlyDeps     = mempty,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = mempty,+    installSymlinkBinDir= mempty,+    installOneShot      = mempty+  }+  mappend a b = InstallFlags {+    installDocumentation= combine installDocumentation,+    installHaddockIndex = combine installHaddockIndex,+    installDryRun       = combine installDryRun,+    installReinstall    = combine installReinstall,+    installUpgradeDeps  = combine installUpgradeDeps,+    installOnly         = combine installOnly,+    installOnlyDeps     = combine installOnlyDeps,+    installRootCmd      = combine installRootCmd,+    installSummaryFile  = combine installSummaryFile,+    installLogFile      = combine installLogFile,+    installBuildReports = combine installBuildReports,+    installSymlinkBinDir= combine installSymlinkBinDir,+    installOneShot      = combine installOneShot+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Upload flags+-- ------------------------------------------------------------++data UploadFlags = UploadFlags {+    uploadCheck     :: Flag Bool,+    uploadUsername  :: Flag Username,+    uploadPassword  :: Flag Password,+    uploadVerbosity :: Flag Verbosity+  }++defaultUploadFlags :: UploadFlags+defaultUploadFlags = UploadFlags {+    uploadCheck     = toFlag False,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = toFlag normal+  }++uploadCommand :: CommandUI UploadFlags+uploadCommand = CommandUI {+    commandName         = "upload",+    commandSynopsis     = "Uploads source packages to Hackage",+    commandDescription  = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = \pname ->+         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"+      ++ "Flags for upload:",+    commandDefaultFlags = defaultUploadFlags,+    commandOptions      = \_ ->+      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })++      ,option ['c'] ["check"]+         "Do not upload, just do QA checks."+        uploadCheck (\v flags -> flags { uploadCheck = v })+        trueArg++      ,option ['u'] ["username"]+        "Hackage username."+        uploadUsername (\v flags -> flags { uploadUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        uploadPassword (\v flags -> flags { uploadPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid UploadFlags where+  mempty = UploadFlags {+    uploadCheck     = mempty,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = mempty+  }+  mappend a b = UploadFlags {+    uploadCheck     = combine uploadCheck,+    uploadUsername  = combine uploadUsername,+    uploadPassword  = combine uploadPassword,+    uploadVerbosity = combine uploadVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Init flags+-- ------------------------------------------------------------++emptyInitFlags :: IT.InitFlags+emptyInitFlags  = mempty++defaultInitFlags :: IT.InitFlags+defaultInitFlags  = emptyInitFlags++initCommand :: CommandUI IT.InitFlags+initCommand = CommandUI {+    commandName = "init",+    commandSynopsis = "Interactively create a .cabal file.",+    commandDescription = Just $ \_ -> wrapText $+         "Cabalise a project by creating a .cabal, Setup.hs, and "+      ++ "optionally a LICENSE file.\n\n"+      ++ "Calling init with no arguments (recommended) uses an "+      ++ "interactive mode, which will try to guess as much as "+      ++ "possible and prompt you for the rest.  Command-line "+      ++ "arguments are provided for scripting purposes. "+      ++ "If you don't want interactive mode, be sure to pass "+      ++ "the -n flag.\n",+    commandUsage = \pname ->+         "Usage: " ++ pname ++ " init [FLAGS]\n\n"+      ++ "Flags for init:",+    commandDefaultFlags = defaultInitFlags,+    commandOptions = \_ ->+      [ option ['n'] ["non-interactive"]+        "Non-interactive mode."+        IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v })+        trueArg++      , option ['q'] ["quiet"]+        "Do not generate log messages to stdout."+        IT.quiet (\v flags -> flags { IT.quiet = v })+        trueArg++      , option [] ["no-comments"]+        "Do not generate explanatory comments in the .cabal file."+        IT.noComments (\v flags -> flags { IT.noComments = v })+        trueArg++      , option ['m'] ["minimal"]+        "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."+        IT.minimal (\v flags -> flags { IT.minimal = v })+        trueArg++      , option [] ["package-dir"]+        "Root directory of the package (default = current directory)."+        IT.packageDir (\v flags -> flags { IT.packageDir = v })+        (reqArgFlag "DIRECTORY")++      , option ['p'] ["package-name"]+        "Name of the Cabal package to create."+        IT.packageName (\v flags -> flags { IT.packageName = v })+        (reqArgFlag "PACKAGE")++      , option [] ["version"]+        "Initial version of the package."+        IT.version (\v flags -> flags { IT.version = v })+        (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option [] ["cabal-version"]+        "Required version of the Cabal library."+        IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })+        (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++)+                                            (toFlag `fmap` parse))+                                (flagToList . fmap display))++      , option ['l'] ["license"]+        "Project license."+        IT.license (\v flags -> flags { IT.license = v })+        (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option ['a'] ["author"]+        "Name of the project's author."+        IT.author (\v flags -> flags { IT.author = v })+        (reqArgFlag "NAME")++      , option ['e'] ["email"]+        "Email address of the maintainer."+        IT.email (\v flags -> flags { IT.email = v })+        (reqArgFlag "EMAIL")++      , option ['u'] ["homepage"]+        "Project homepage and/or repository."+        IT.homepage (\v flags -> flags { IT.homepage = v })+        (reqArgFlag "URL")++      , option ['s'] ["synopsis"]+        "Short project synopsis."+        IT.synopsis (\v flags -> flags { IT.synopsis = v })+        (reqArgFlag "TEXT")++      , option ['c'] ["category"]+        "Project category."+        IT.category (\v flags -> flags { IT.category = v })+        (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))+                            (flagToList . fmap (either id show)))++      , option [] ["is-library"]+        "Build a library."+        IT.packageType (\v flags -> flags { IT.packageType = v })+        (noArg (Flag IT.Library))++      , option [] ["is-executable"]+        "Build an executable."+        IT.packageType+        (\v flags -> flags { IT.packageType = v })+        (noArg (Flag IT.Executable))++      , option ['o'] ["expose-module"]+        "Export a module from the package."+        IT.exposedModules+        (\v flags -> flags { IT.exposedModules = v })+        (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)+                                     ((Just . (:[])) `fmap` parse))+                         (fromMaybe [] . fmap (fmap display)))++      , option ['d'] ["dependency"]+        "Package dependency."+        IT.dependencies (\v flags -> flags { IT.dependencies = v })+        (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)+                                      ((Just . (:[])) `fmap` parse))+                          (fromMaybe [] . fmap (fmap display)))++      , option [] ["source-dir"]+        "Directory containing package source."+        IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })+        (reqArg' "DIR" (Just . (:[]))+                       (fromMaybe []))++      , option [] ["build-tool"]+        "Required external build tool."+        IT.buildTools (\v flags -> flags { IT.buildTools = v })+        (reqArg' "TOOL" (Just . (:[]))+                        (fromMaybe []))+      ]+  }+  where readMaybe s = case reads s of+                        [(x,"")]  -> Just x+                        _         -> Nothing++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt  = Command.boolOpt  flagToMaybe Flag++reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->+              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++liftOptions :: (b -> a) -> (a -> b -> b)+            -> [OptionField a] -> [OptionField b]+liftOptions get set = map (liftOption get set)++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"+  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++--TODO: do we want to allow per-package flags?+parsePackageArgs :: [String] -> Either String [Dependency]+parsePackageArgs = parsePkgArgs []+  where+    parsePkgArgs ds [] = Right (reverse ds)+    parsePkgArgs ds (arg:args) =+      case readPToMaybe parseDependencyOrPackageId arg of+        Just dep -> parsePkgArgs (dep:ds) args+        Nothing  -> Left $+         show arg ++ " is not valid syntax for a package name or"+                  ++ " package dependency."++readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]++parseDependencyOrPackageId :: Parse.ReadP r Dependency+parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+  where+    pkgidToDependency :: PackageIdentifier -> Dependency+    pkgidToDependency p = case packageVersion p of+      Version [] _ -> Dependency (packageName p) anyVersion+      version      -> Dependency (packageName p) (thisVersion version)++showRepo :: RemoteRepo -> String+showRepo repo = remoteRepoName repo ++ ":"+             ++ uriToString id (remoteRepoURI repo) []++readRepo :: String -> Maybe RemoteRepo+readRepo = readPToMaybe parseRepo++parseRepo :: Parse.ReadP r RemoteRepo+parseRepo = do+  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+  _ <- Parse.char ':'+  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")+  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)+  return $ RemoteRepo {+    remoteRepoName = name,+    remoteRepoURI  = uri+  }
+ Distribution/Client/SetupWrapper.hs view
@@ -0,0 +1,320 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SetupWrapper+-- Copyright   :  (c) The University of Glasgow 2006,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- An interface to building and installing Cabal packages.+-- If the @Built-Type@ field is specified as something other than+-- 'Custom', and the current version of Cabal is acceptable, this performs+-- setup actions directly.  Otherwise it builds the setup script and+-- runs it with the given arguments.++module Distribution.Client.SetupWrapper (+    setupWrapper,+    SetupScriptOptions(..),+    defaultSetupScriptOptions,+  ) where++import Distribution.Client.Types+         ( InstalledPackage )++import qualified Distribution.Make as Make+import qualified Distribution.Simple as Simple+import Distribution.Version+         ( Version(..), VersionRange, anyVersion+         , intersectVersionRanges, orLaterVersion+         , withinRange )+import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         , packageVersion, Dependency(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(..), specVersion, BuildType(..) )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Configure+         ( configCompiler )+import Distribution.Simple.Compiler+         ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration, emptyProgramConfiguration+         , rawSystemProgramConf, ghcProgram )+import Distribution.Simple.BuildPaths+         ( defaultDistPref, exeExtension )+import Distribution.Simple.Command+         ( CommandUI(..), commandShowOptions )+import Distribution.Simple.GHC+         ( ghcVerbosityOptions )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.IndexUtils+         ( getInstalledPackages )+import Distribution.Simple.Utils+         ( die, debug, info, cabalVersion, findPackageDesc, comparing+         , createDirectoryIfMissingVerbose, rewriteFile )+import Distribution.Client.Utils+         ( moreRecentFile, inDir )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import System.Directory  ( doesFileExist, getCurrentDirectory )+import System.FilePath   ( (</>), (<.>) )+import System.IO         ( Handle )+import System.Exit       ( ExitCode(..), exitWith )+import System.Process    ( runProcess, waitForProcess )+import Control.Monad     ( when, unless )+import Data.List         ( maximumBy )+import Data.Maybe        ( fromMaybe, isJust )+import Data.Char         ( isSpace )++data SetupScriptOptions = SetupScriptOptions {+    useCabalVersion  :: VersionRange,+    useCompiler      :: Maybe Compiler,+    usePackageDB     :: PackageDBStack,+    usePackageIndex  :: Maybe (PackageIndex InstalledPackage),+    useProgramConfig :: ProgramConfiguration,+    useDistPref      :: FilePath,+    useLoggingHandle :: Maybe Handle,+    useWorkingDir    :: Maybe FilePath+  }++defaultSetupScriptOptions :: SetupScriptOptions+defaultSetupScriptOptions = SetupScriptOptions {+    useCabalVersion  = anyVersion,+    useCompiler      = Nothing,+    usePackageDB     = [GlobalPackageDB, UserPackageDB],+    usePackageIndex  = Nothing,+    useProgramConfig = emptyProgramConfiguration,+    useDistPref      = defaultDistPref,+    useLoggingHandle = Nothing,+    useWorkingDir    = Nothing+  }++setupWrapper :: Verbosity+             -> SetupScriptOptions+             -> Maybe PackageDescription+             -> CommandUI flags+             -> (Version -> flags)+             -> [String]+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  pkg <- maybe getPkg return mpkg+  let setupMethod = determineSetupMethod options' buildType'+      options'    = options {+                      useCabalVersion = intersectVersionRanges+                                          (useCabalVersion options)+                                          (orLaterVersion (specVersion pkg))+                    }+      buildType'  = fromMaybe Custom (buildType pkg)+      mkArgs cabalLibVersion = commandName cmd+                             : commandShowOptions cmd (flags cabalLibVersion)+                            ++ extraArgs+  setupMethod verbosity options' (packageId pkg) buildType' mkArgs+  where+    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))+         >>= readPackageDescription verbosity+         >>= return . packageDescription++-- | Decide if we're going to be able to do a direct internal call to the+-- entry point in the Cabal library or if we're going to have to compile+-- and execute an external Setup.hs script.+--+determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod+determineSetupMethod options buildType'+  | isJust (useLoggingHandle options)+ || buildType' == Custom      = externalSetupMethod+  | cabalVersion `withinRange`+      useCabalVersion options = internalSetupMethod+  | otherwise                 = externalSetupMethod++type SetupMethod = Verbosity+                -> SetupScriptOptions+                -> PackageIdentifier+                -> BuildType+                -> (Version -> [String]) -> IO ()++-- ------------------------------------------------------------+-- * Internal SetupMethod+-- ------------------------------------------------------------++internalSetupMethod :: SetupMethod+internalSetupMethod verbosity options _ bt mkargs = do+  let args = mkargs cabalVersion+  debug verbosity $ "Using internal setup method with build-type " ++ show bt+                 ++ " and args:\n  " ++ show args+  inDir (useWorkingDir options) $+    buildTypeAction bt args++buildTypeAction :: BuildType -> ([String] -> IO ())+buildTypeAction Simple    = Simple.defaultMainArgs+buildTypeAction Configure = Simple.defaultMainWithHooksArgs+                              Simple.autoconfUserHooks+buildTypeAction Make      = Make.defaultMainArgs+buildTypeAction Custom               = error "buildTypeAction Custom"+buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"++-- ------------------------------------------------------------+-- * External SetupMethod+-- ------------------------------------------------------------++externalSetupMethod :: SetupMethod+externalSetupMethod verbosity options pkg bt mkargs = do+  debug verbosity $ "Using external setup method with build-type " ++ show bt+  createDirectoryIfMissingVerbose verbosity True setupDir+  (cabalLibVersion, options') <- cabalLibVersionToUse+  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion+  setupHs <- updateSetupScript cabalLibVersion bt+  debug verbosity $ "Using " ++ setupHs ++ " as setup script."+  compileSetupExecutable options' cabalLibVersion setupHs+  invokeSetupScript (mkargs cabalLibVersion)++  where+  workingDir       = case fromMaybe "" (useWorkingDir options) of+                       []  -> "."+                       dir -> dir+  setupDir         = workingDir </> useDistPref options </> "setup"+  setupVersionFile = setupDir </> "setup" <.> "version"+  setupProgFile    = setupDir </> "setup" <.> exeExtension++  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)+  cabalLibVersionToUse = do+    savedVersion <- savedCabalVersion+    case savedVersion of+      Just version | version `withinRange` useCabalVersion options+        -> return (version, options)+      _ -> do (comp, conf, options') <- configureCompiler options+              version <- installedCabalVersion options comp conf+              writeFile setupVersionFile (show version ++ "\n")+              return (version, options')++  savedCabalVersion = do+    versionString <- readFile setupVersionFile `catch` \_ -> return ""+    case reads versionString of+      [(version,s)] | all isSpace s -> return (Just version)+      _                             -> return Nothing++  installedCabalVersion :: SetupScriptOptions -> Compiler+                        -> ProgramConfiguration -> IO Version+  installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" =+    return (packageVersion pkg)+  installedCabalVersion options' comp conf = do+    index <- case usePackageIndex options' of+      Just index -> return index+      Nothing    -> getInstalledPackages verbosity+                      comp (usePackageDB options') conf++    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)+    case PackageIndex.lookupDependency index cabalDep of+      []   -> die $ "The package requires Cabal library version "+                 ++ display (useCabalVersion options)+                 ++ " but no suitable version is installed."+      pkgs -> return $ bestVersion (map packageVersion pkgs)+    where+      bestVersion          = maximumBy (comparing preference)+      preference version   = (sameVersion, sameMajorVersion+                             ,stableVersion, latestVersion)+        where+          sameVersion      = version == cabalVersion+          sameMajorVersion = majorVersion version == majorVersion cabalVersion+          majorVersion     = take 2 . versionBranch+          stableVersion    = case versionBranch version of+                               (_:x:_) -> even x+                               _       -> False+          latestVersion    = version++  configureCompiler :: SetupScriptOptions+                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)+  configureCompiler options' = do+    (comp, conf) <- case useCompiler options' of+      Just comp -> return (comp, useProgramConfig options')+      Nothing   -> configCompiler (Just GHC) Nothing Nothing+                     (useProgramConfig options') verbosity+    return (comp, conf, options' { useCompiler = Just comp,+                                   useProgramConfig = conf })++  -- | Decide which Setup.hs script to use, creating it if necessary.+  --+  updateSetupScript :: Version -> BuildType -> IO FilePath+  updateSetupScript _ Custom = do+    useHs  <- doesFileExist setupHs+    useLhs <- doesFileExist setupLhs+    unless (useHs || useLhs) $ die+      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."+    return (if useHs then setupHs else setupLhs)+    where+      setupHs  = workingDir </> "Setup.hs"+      setupLhs = workingDir </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ = do+    rewriteFile setupHs (buildTypeScript cabalLibVersion)+    return setupHs+    where+      setupHs  = setupDir </> "setup.hs"++  buildTypeScript :: Version -> String+  buildTypeScript cabalLibVersion = case bt of+    Simple    -> "import Distribution.Simple; main = defaultMain\n"+    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "+              ++ if cabalLibVersion >= Version [1,3,10] []+                   then "autoconfUserHooks\n"+                   else "defaultUserHooks\n"+    Make      -> "import Distribution.Make; main = defaultMain\n"+    Custom             -> error "buildTypeScript Custom"+    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"++  -- | If the Setup.hs is out of date wrt the executable then recompile it.+  -- Currently this is GHC only. It should really be generalised.+  --+  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()+  compileSetupExecutable options' cabalLibVersion setupHsFile = do+    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile+    cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile+    let outOfDate = setupHsNewer || cabalVersionNewer+    when outOfDate $ do+      debug verbosity "Setup script is out of date, compiling..."+      (_, conf, _) <- configureCompiler options'+      --TODO: get Cabal's GHC module to export a GhcOptions type and render func+      rawSystemProgramConf verbosity ghcProgram conf $+          ghcVerbosityOptions verbosity+       ++ ["--make", setupHsFile, "-o", setupProgFile+          ,"-odir", setupDir, "-hidir", setupDir+          ,"-i", "-i" ++ workingDir ]+       ++ ghcPackageDbOptions (usePackageDB options')+       ++ if packageName pkg == PackageName "Cabal"+            then []+            else ["-package", display cabalPkgid]+    where+      cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion++      ghcPackageDbOptions :: PackageDBStack -> [String]+      ghcPackageDbOptions dbstack = case dbstack of+        (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+        (GlobalPackageDB:dbs)               -> "-no-user-package-conf"+                                             : concatMap specific dbs+        _                                   -> ierror+        where+          specific (SpecificPackageDB db) = [ "-package-conf", db ]+          specific _ = ierror+          ierror     = error "internal error: unexpected package db stack"+++  invokeSetupScript :: [String] -> IO ()+  invokeSetupScript args = do+    info verbosity $ unwords (setupProgFile : args)+    case useLoggingHandle options of+      Nothing        -> return ()+      Just logHandle -> info verbosity $ "Redirecting build log to "+                                      ++ show logHandle+    currentDir <- getCurrentDirectory+    process <- runProcess (currentDir </> setupProgFile) args+                 (useWorkingDir options) Nothing+                 Nothing (useLoggingHandle options) (useLoggingHandle options)+    exitCode <- waitForProcess process+    unless (exitCode == ExitSuccess) $ exitWith exitCode
+ Distribution/Client/SrcDist.hs view
@@ -0,0 +1,80 @@+-- Implements the \"@.\/cabal sdist@\" command, which creates a source+-- distribution for this package.  That is, packs up the source code+-- into a tarball, making use of the corresponding Cabal module.+module Distribution.Client.SrcDist (+         sdist+  )  where+import Distribution.Simple.SrcDist+         ( printPackageProblems, prepareTree+         , prepareSnapshotTree, snapshotPackage )+import Distribution.Client.Tar (createTarGzFile)++import Distribution.Package+         ( Package(..) )+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Utils+         ( defaultPackageDesc, warn, notice, setupMessage+         , createDirectoryIfMissingVerbose, withTempDirectory )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.PreProcess (knownSuffixHandlers)+import Distribution.Simple.BuildPaths ( srcPref)+import Distribution.Simple.Configure(maybeGetPersistBuildConfig)+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Text+         ( display )++import System.Time (getClockTime, toCalendarTime)+import System.FilePath ((</>), (<.>))+import Control.Monad (when)+import Data.Maybe (isNothing)++-- |Create a source distribution.+sdist :: SDistFlags -> IO ()+sdist flags = do+  pkg <- return . flattenPackageDescription+     =<< readPackageDescription verbosity+     =<< defaultPackageDesc verbosity+  mb_lbi <- maybeGetPersistBuildConfig distPref+  let tmpTargetDir = srcPref distPref++  -- do some QA+  printPackageProblems verbosity pkg++  when (isNothing mb_lbi) $+    warn verbosity "Cannot run preprocessors. Run 'configure' command first."++  createDirectoryIfMissingVerbose verbosity True tmpTargetDir+  withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do++    date <- toCalendarTime =<< getClockTime+    let pkg' | snapshot  = snapshotPackage date pkg+             | otherwise = pkg+    setupMessage verbosity "Building source dist for" (packageId pkg')++    _ <- if snapshot+      then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps+      else prepareTree         verbosity pkg' mb_lbi distPref tmpDir pps+    targzFile <- createArchive verbosity pkg' tmpDir distPref+    notice verbosity $ "Source tarball created: " ++ targzFile++  where+    verbosity = fromFlag (sDistVerbosity flags)+    snapshot  = fromFlag (sDistSnapshot flags)+    distPref  = fromFlag (sDistDistPref flags)+    pps       = knownSuffixHandlers++-- |Create an archive from a tree of source files, and clean up the tree.+createArchive :: Verbosity+              -> PackageDescription+              -> FilePath+              -> FilePath+              -> IO FilePath+createArchive _verbosity pkg tmpDir targetPref = do+  let tarBallName     = display (packageId pkg)+      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"+  createTarGzFile tarBallFilePath tmpDir tarBallName+  return tarBallFilePath
+ Distribution/Client/Tar.hs view
@@ -0,0 +1,903 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Tar+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2009 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-- Reading, writing and manipulating \"@.tar@\" archive files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Tar (+  -- * High level \"all in one\" operations+  createTarGzFile,+  extractTarGzFile,++  -- * Converting between internal and external representation+  read,+  write,++  -- * Packing and unpacking files to\/from internal representation+  pack,+  unpack,++  -- * Tar entry and associated types+  Entry(..),+  entryPath,+  EntryContent(..),+  Ownership(..),+  FileSize,+  Permissions,+  EpochTime,+  DevMajor,+  DevMinor,+  TypeCode,+  Format(..),++  -- * Constructing simple entry values+  simpleEntry,+  fileEntry,+  directoryEntry,++  -- * TarPath type+  TarPath,+  toTarPath,+  fromTarPath,++  -- ** Sequences of tar entries+  Entries(..),+  foldrEntries,+  foldlEntries,+  unfoldrEntries,+  mapEntries,+  filterEntries,+  entriesIndex,++  ) where++import Data.Char     (ord)+import Data.Int      (Int64)+import Data.Bits     (Bits, shiftL, testBit)+import Data.List     (foldl')+import Numeric       (readOct, showOct)+import Control.Monad (MonadPlus(mplus), when)+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import qualified Codec.Compression.GZip as GZip+import qualified Distribution.Client.GZipUtils as GZipUtils++import System.FilePath+         ( (</>) )+import qualified System.FilePath         as FilePath.Native+import qualified System.FilePath.Windows as FilePath.Windows+import qualified System.FilePath.Posix   as FilePath.Posix+import System.Directory+         ( getDirectoryContents, doesDirectoryExist, getModificationTime+         , getPermissions, createDirectoryIfMissing, copyFile )+import qualified System.Directory as Permissions+         ( Permissions(executable) )+import Distribution.Compat.FilePerms+         ( setFileExecutable )+import System.Posix.Types+         ( FileMode )+import System.Time+         ( ClockTime(..) )+import System.IO+         ( IOMode(ReadMode), openBinaryFile, hFileSize )+import System.IO.Unsafe (unsafeInterleaveIO)++import Prelude hiding (read)+++--+-- * High level operations+--++createTarGzFile :: FilePath  -- ^ Full Tarball path+                -> FilePath  -- ^ Base directory+                -> FilePath  -- ^ Directory to archive, relative to base dir+                -> IO ()+createTarGzFile tar base dir =+  BS.writeFile tar . GZip.compress . write =<< pack base [dir]++extractTarGzFile :: FilePath -- ^ Destination directory+                 -> FilePath -- ^ Expected subdir (to check for tarbombs)+                 -> FilePath -- ^ Tarball+                -> IO ()+extractTarGzFile dir expected tar = do+  unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar++--+-- * Entry type+--++type FileSize  = Int64+-- | The number of seconds since the UNIX epoch+type EpochTime = Int64+type DevMajor  = Int+type DevMinor  = Int+type TypeCode  = Char+type Permissions = FileMode++-- | Tar archive entry.+--+data Entry = Entry {++    -- | The path of the file or directory within the archive. This is in a+    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.+    entryTarPath :: !TarPath,++    -- | The real content of the entry. For 'NormalFile' this includes the+    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.+    entryContent :: !EntryContent,++    -- | File permissions (Unix style file mode).+    entryPermissions :: !Permissions,++    -- | The user and group to which this file belongs.+    entryOwnership :: !Ownership,++    -- | The time the file was last modified.+    entryTime :: !EpochTime,++    -- | The tar format the archive is using.+    entryFormat :: !Format+  }++-- | Native 'FilePath' of the file or directory within the archive.+--+entryPath :: Entry -> FilePath+entryPath = fromTarPath . entryTarPath++-- | The content of a tar archive entry, which depends on the type of entry.+--+-- Portable archives should contain only 'NormalFile' and 'Directory'.+--+data EntryContent = NormalFile      ByteString !FileSize+                  | Directory+                  | SymbolicLink    !LinkTarget+                  | HardLink        !LinkTarget+                  | CharacterDevice !DevMajor !DevMinor+                  | BlockDevice     !DevMajor !DevMinor+                  | NamedPipe+                  | OtherEntryType  !TypeCode ByteString !FileSize++data Ownership = Ownership {+    -- | The owner user name. Should be set to @\"\"@ if unknown.+    ownerName :: String,++    -- | The owner group name. Should be set to @\"\"@ if unknown.+    groupName :: String,++    -- | Numeric owner user id. Should be set to @0@ if unknown.+    ownerId :: !Int,++    -- | Numeric owner group id. Should be set to @0@ if unknown.+    groupId :: !Int+  }++-- | There have been a number of extensions to the tar file format over the+-- years. They all share the basic entry fields and put more meta-data in+-- different extended headers.+--+data Format =++     -- | This is the classic Unix V7 tar format. It does not support owner and+     -- group names, just numeric Ids. It also does not support device numbers.+     V7Format++     -- | The \"USTAR\" format is an extension of the classic V7 format. It was+     -- later standardised by POSIX. It has some restructions but is the most+     -- portable format.+     --+   | UstarFormat++     -- | The GNU tar implementation also extends the classic V7 format, though+     -- in a slightly different way from the USTAR format. In general for new+     -- archives the standard USTAR/POSIX should be used.+     --+   | GnuFormat+  deriving Eq++-- | @rw-r--r--@ for normal files+ordinaryFilePermissions :: Permissions+ordinaryFilePermissions   = 0o0644++-- | @rwxr-xr-x@ for executable files+executableFilePermissions :: Permissions+executableFilePermissions = 0o0755++-- | @rwxr-xr-x@ for directories+directoryPermissions :: Permissions+directoryPermissions  = 0o0755++isExecutable :: Permissions -> Bool+isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable++-- | An 'Entry' with all default values except for the file name and type. It+-- uses the portable USTAR/POSIX format (see 'UstarHeader').+--+-- You can use this as a basis and override specific fields, eg:+--+-- > (emptyEntry name HardLink) { linkTarget = target }+--+simpleEntry :: TarPath -> EntryContent -> Entry+simpleEntry tarpath content = Entry {+    entryTarPath     = tarpath,+    entryContent     = content,+    entryPermissions = case content of+                         Directory -> directoryPermissions+                         _         -> ordinaryFilePermissions,+    entryOwnership   = Ownership "" "" 0 0,+    entryTime        = 0,+    entryFormat      = UstarFormat+  }++-- | A tar 'Entry' for a file.+--+-- Entry  fields such as file permissions and ownership have default values.+--+-- You can use this as a basis and override specific fields. For example if you+-- need an executable file you could use:+--+-- > (fileEntry name content) { fileMode = executableFileMode }+--+fileEntry :: TarPath -> ByteString -> Entry+fileEntry name fileContent =+  simpleEntry name (NormalFile fileContent (BS.length fileContent))++-- | A tar 'Entry' for a directory.+--+-- Entry fields such as file permissions and ownership have default values.+--+directoryEntry :: TarPath -> Entry+directoryEntry name = simpleEntry name Directory++--+-- * Tar paths+--++-- | The classic tar format allowed just 100 charcters for the file name. The+-- USTAR format extended this with an extra 155 characters, however it uses a+-- complex method of splitting the name between the two sections.+--+-- Instead of just putting any overflow into the extended area, it uses the+-- extended area as a prefix. The agrevating insane bit however is that the+-- prefix (if any) must only contain a directory prefix. That is the split+-- between the two areas must be on a directory separator boundary. So there is+-- no simple calculation to work out if a file name is too long. Instead we+-- have to try to find a valid split that makes the name fit in the two areas.+--+-- The rationale presumably was to make it a bit more compatible with old tar+-- programs that only understand the classic format. A classic tar would be+-- able to extract the file name and possibly some dir prefix, but not the+-- full dir prefix. So the files would end up in the wrong place, but that's+-- probably better than ending up with the wrong names too.+--+-- So it's understandable but rather annoying.+--+-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective+--   of the local path conventions.+--+-- * The directory separator between the prefix and name is /not/ stored.+--+data TarPath = TarPath FilePath -- path name, 100 characters max.+                       FilePath -- path prefix, 155 characters max.+  deriving (Eq, Ord)++-- | Convert a 'TarPath' to a native 'FilePath'.+--+-- The native 'FilePath' will use the native directory separator but it is not+-- otherwise checked for validity or sanity. In particular:+--+-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is+--   not valid on Windows.+--+-- * The tar path may be an absolute path or may contain @\"..\"@ components.+--   For security reasons this should not usually be allowed, but it is your+--   responsibility to check for these conditions (eg using 'checkSecurity').+--+fromTarPath :: TarPath -> FilePath+fromTarPath (TarPath name prefix) = adjustDirectory $+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix+                          ++ FilePath.Posix.splitDirectories name+  where+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Native.addTrailingPathSeparator+                    | otherwise = id++-- | Convert a native 'FilePath' to a 'TarPath'.+--+-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a+-- description of the problem with splitting long 'FilePath's.+--+toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for+                  -- directories a 'TarPath' must always use a trailing @\/@.+          -> FilePath -> Either String TarPath+toTarPath isDir = splitLongPath+                . addTrailingSep+                . FilePath.Posix.joinPath+                . FilePath.Native.splitDirectories+  where+    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator+                   | otherwise = id++-- | Take a sanitized path, split on directory separators and try to pack it+-- into the 155 + 100 tar file name format.+--+-- The stragey is this: take the name-directory components in reverse order+-- and try to fit as many components into the 100 long name area as possible.+-- If all the remaining components fit in the 155 name area then we win.+--+splitLongPath :: FilePath -> Either String TarPath+splitLongPath path =+  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of+    Left err                 -> Left err+    Right (name, [])         -> Right (TarPath name "")+    Right (name, first:rest) -> case packName prefixMax remainder of+      Left err               -> Left err+      Right (_     , (_:_))  -> Left "File name too long (cannot split)"+      Right (prefix, [])     -> Right (TarPath name prefix)+      where+        -- drop the '/' between the name and prefix:+        remainder = init first : rest++  where+    nameMax, prefixMax :: Int+    nameMax   = 100+    prefixMax = 155++    packName _      []     = Left "File name empty"+    packName maxLen (c:cs)+      | n > maxLen         = Left "File name too long"+      | otherwise          = Right (packName' maxLen n [c] cs)+      where n = length c++    packName' maxLen n ok (c:cs)+      | n' <= maxLen             = packName' maxLen n' (c:ok) cs+                                     where n' = n + length c+    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)++-- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and+-- 'HardLink' entry types.+--+newtype LinkTarget = LinkTarget FilePath+  deriving (Eq, Ord)++-- | Convert a tar 'LinkTarget' to a native 'FilePath'.+--+fromLinkTarget :: LinkTarget -> FilePath+fromLinkTarget (LinkTarget path) = adjustDirectory $+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path+  where+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path+                    = FilePath.Native.addTrailingPathSeparator+                    | otherwise = id++--+-- * Entries type+--++-- | A tar archive is a sequence of entries.+data Entries = Next Entry Entries+             | Done+             | Fail String++unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries+unfoldrEntries f = unfold+  where+    unfold x = case f x of+      Left err             -> Fail err+      Right Nothing        -> Done+      Right (Just (e, x')) -> Next e (unfold x')++foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a+foldrEntries next done fail' = fold+  where+    fold (Next e es) = next e (fold es)+    fold Done        = done+    fold (Fail err)  = fail' err++foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a+foldlEntries f = fold+  where+    fold a (Next e es) = (fold $! f a e) es+    fold a Done        = Right a+    fold _ (Fail err)  = Left err++mapEntries :: (Entry -> Entry) -> Entries -> Entries+mapEntries f = foldrEntries (Next . f) Done Fail++filterEntries :: (Entry -> Bool) -> Entries -> Entries+filterEntries p =+  foldrEntries+    (\entry rest -> if p entry+                      then Next entry rest+                      else rest)+    Done Fail++checkEntries :: (Entry -> Maybe String) -> Entries -> Entries+checkEntries checkEntry =+  foldrEntries+    (\entry rest -> case checkEntry entry of+                      Nothing  -> Next entry rest+                      Just err -> Fail err)+    Done Fail++entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)+entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty++--+-- * Checking+--++-- | This function checks a sequence of tar entries for file name security+-- problems. It checks that:+--+-- * file paths are not absolute+--+-- * file paths do not contain any path components that are \"@..@\"+--+-- * file names are valid+--+-- These checks are from the perspective of the current OS. That means we check+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive+-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the+-- link target. A failure in any entry terminates the sequence of entries with+-- an error.+--+checkSecurity :: Entries -> Entries+checkSecurity = checkEntries checkEntrySecurity++checkTarbomb :: FilePath -> Entries -> Entries+checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)++checkEntrySecurity :: Entry -> Maybe String+checkEntrySecurity entry = case entryContent entry of+    HardLink     link -> check (entryPath entry)+                 `mplus` check (fromLinkTarget link)+    SymbolicLink link -> check (entryPath entry)+                 `mplus` check (fromLinkTarget link)+    _                 -> check (entryPath entry)++  where+    check name+      | not (FilePath.Native.isRelative name)+      = Just $ "Absolute file name in tar archive: " ++ show name++      | not (FilePath.Native.isValid name)+      = Just $ "Invalid file name in tar archive: " ++ show name++      | any (=="..") (FilePath.Native.splitDirectories name)+      = Just $ "Invalid file name in tar archive: " ++ show name++      | otherwise = Nothing++checkEntryTarbomb :: FilePath -> Entry -> Maybe String+checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing+  where+    -- Ignore some special entries we will not unpack anyway+    nonFilesystemEntry =+      case entryContent entry of+        OtherEntryType 'g' _ _ -> True --PAX global header+        OtherEntryType 'x' _ _ -> True --PAX individual header+        _                      -> False++checkEntryTarbomb expectedTopDir entry =+  case FilePath.Native.splitDirectories (entryPath entry) of+    (topDir:_) | topDir == expectedTopDir -> Nothing+    _ -> Just $ "File in tar archive is not in the expected directory "+             ++ show expectedTopDir+++--+-- * Reading+--++read :: ByteString -> Entries+read = unfoldrEntries getEntry++getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))+getEntry bs+  | BS.length header < 512 = Left "truncated tar archive"++  -- Tar files end with at least two blocks of all '0'. Checking this serves+  -- two purposes. It checks the format but also forces the tail of the data+  -- which is necessary to close the file if it came from a lazily read file.+  | BS.head bs == 0 = case BS.splitAt 1024 bs of+      (end, trailing)+        | BS.length end /= 1024        -> Left "short tar trailer"+        | not (BS.all (== 0) end)      -> Left "bad tar trailer"+        | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"+        | otherwise                    -> Right Nothing++  | otherwise  = partial $ do++  case (chksum_, format_) of+    (Ok chksum, _   ) | correctChecksum header chksum -> return ()+    (Ok _,      Ok _) -> fail "tar checksum error"+    _                 -> fail "data is not in tar format"++  -- These fields are partial, have to check them+  format   <- format_;   mode     <- mode_;+  uid      <- uid_;      gid      <- gid_;+  size     <- size_;     mtime    <- mtime_;+  devmajor <- devmajor_; devminor <- devminor_;++  let content = BS.take size (BS.drop 512 bs)+      padding = (512 - size) `mod` 512+      bs'     = BS.drop (512 + size + padding) bs++      entry = Entry {+        entryTarPath     = TarPath name prefix,+        entryContent     = case typecode of+                   '\0' -> NormalFile      content size+                   '0'  -> NormalFile      content size+                   '1'  -> HardLink        (LinkTarget linkname)+                   '2'  -> SymbolicLink    (LinkTarget linkname)+                   '3'  -> CharacterDevice devmajor devminor+                   '4'  -> BlockDevice     devmajor devminor+                   '5'  -> Directory+                   '6'  -> NamedPipe+                   '7'  -> NormalFile      content size+                   _    -> OtherEntryType  typecode content size,+        entryPermissions = mode,+        entryOwnership   = Ownership uname gname uid gid,+        entryTime        = mtime,+        entryFormat      = format+    }++  return (Just (entry, bs'))++  where+   header = BS.take 512 bs++   name       = getString   0 100 header+   mode_      = getOct    100   8 header+   uid_       = getOct    108   8 header+   gid_       = getOct    116   8 header+   size_      = getOct    124  12 header+   mtime_     = getOct    136  12 header+   chksum_    = getOct    148   8 header+   typecode   = getByte   156     header+   linkname   = getString 157 100 header+   magic      = getChars  257   8 header+   uname      = getString 265  32 header+   gname      = getString 297  32 header+   devmajor_  = getOct    329   8 header+   devminor_  = getOct    337   8 header+   prefix     = getString 345 155 header+-- trailing   = getBytes  500  12 header++   format_ = case magic of+    "\0\0\0\0\0\0\0\0" -> return V7Format+    "ustar\NUL00"      -> return UstarFormat+    "ustar  \NUL"      -> return GnuFormat+    _                  -> fail "tar entry not in a recognised format"++correctChecksum :: ByteString -> Int -> Bool+correctChecksum header checksum = checksum == checksum'+  where+    -- sum of all 512 bytes in the header block,+    -- treating each byte as an 8-bit unsigned value+    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'+    -- treating the 8 bytes of chksum as blank characters.+    header'   = BS.concat [BS.take 148 header,+                           BS.Char8.replicate 8 ' ',+                           BS.drop 156 header]++-- * TAR format primitive input++getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a+getOct off len header+  | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))+  | null octstr          = return 0+  | otherwise            = case readOct octstr of+               [(x,[])] -> return x+               _        -> fail "tar header is malformed (bad numeric encoding)"+  where+    bytes  = getBytes off len header+    octstr = BS.Char8.unpack+           . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')+           . BS.Char8.dropWhile (== ' ')+           $ bytes++    -- Some tar programs switch into a binary format when they try to represent+    -- field values that will not fit in the required width when using the text+    -- octal format. In particular, the UID/GID fields can only hold up to 2^21+    -- while in the binary format can hold up to 2^32. The binary format uses+    -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.+    parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =+      return $! shiftL (fromIntegral byte3) 24+              + shiftL (fromIntegral byte2) 16+              + shiftL (fromIntegral byte1) 8+              + shiftL (fromIntegral byte0) 0+    parseBinInt _ = fail "tar header uses non-standard number encoding"++getBytes :: Int64 -> Int64 -> ByteString -> ByteString+getBytes off len = BS.take len . BS.drop off++getByte :: Int64 -> ByteString -> Char+getByte off bs = BS.Char8.index bs off++getChars :: Int64 -> Int64 -> ByteString -> String+getChars off len = BS.Char8.unpack . getBytes off len++getString :: Int64 -> Int64 -> ByteString -> String+getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len++data Partial a = Error String | Ok a++partial :: Partial a -> Either String a+partial (Error msg) = Left msg+partial (Ok x)      = Right x++instance Monad Partial where+    return        = Ok+    Error m >>= _ = Error m+    Ok    x >>= k = k x+    fail          = Error++--+-- * Writing+--++-- | Create the external representation of a tar archive by serialising a list+-- of tar entries.+--+-- * The conversion is done lazily.+--+write :: [Entry] -> ByteString+write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]++putEntry :: Entry -> ByteString+putEntry entry = case entryContent entry of+  NormalFile       content size -> BS.concat [ header, content, padding size ]+  OtherEntryType _ content size -> BS.concat [ header, content, padding size ]+  _                             -> header+  where+    header       = putHeader entry+    padding size = BS.replicate paddingSize 0+      where paddingSize = fromIntegral (negate size `mod` 512)++putHeader :: Entry -> ByteString+putHeader entry =+     BS.Char8.pack $ take 148 block+  ++ putOct 7 checksum+  ++ ' ' : drop 156 block+  where+    block    = putHeaderNoChkSum entry+    checksum = foldl' (\x y -> x + ord y) 0 block++putHeaderNoChkSum :: Entry -> String+putHeaderNoChkSum Entry {+    entryTarPath     = TarPath name prefix,+    entryContent     = content,+    entryPermissions = permissions,+    entryOwnership   = ownership,+    entryTime        = modTime,+    entryFormat      = format+  } =++  concat+    [ putString  100 $ name+    , putOct       8 $ permissions+    , putOct       8 $ ownerId ownership+    , putOct       8 $ groupId ownership+    , putOct      12 $ contentSize+    , putOct      12 $ modTime+    , fill         8 $ ' ' -- dummy checksum+    , putChar8       $ typeCode+    , putString  100 $ linkTarget+    ] +++  case format of+  V7Format    ->+      fill 255 '\NUL'+  UstarFormat -> concat+    [ putString    8 $ "ustar\NUL00"+    , putString   32 $ ownerName ownership+    , putString   32 $ groupName ownership+    , putOct       8 $ deviceMajor+    , putOct       8 $ deviceMinor+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  GnuFormat -> concat+    [ putString    8 $ "ustar  \NUL"+    , putString   32 $ ownerName ownership+    , putString   32 $ groupName ownership+    , putGnuDev    8 $ deviceMajor+    , putGnuDev    8 $ deviceMinor+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  where+    (typeCode, contentSize, linkTarget,+     deviceMajor, deviceMinor) = case content of+       NormalFile      _ size            -> ('0' , size, [],   0,     0)+       Directory                         -> ('5' , 0,    [],   0,     0)+       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link, 0,     0)+       HardLink        (LinkTarget link) -> ('1' , 0,    link, 0,     0)+       CharacterDevice major minor       -> ('3' , 0,    [],   major, minor)+       BlockDevice     major minor       -> ('4' , 0,    [],   major, minor)+       NamedPipe                         -> ('6' , 0,    [],   0,     0)+       OtherEntryType  code _ size       -> (code, size, [],   0,     0)++    putGnuDev w n = case content of+      CharacterDevice _ _ -> putOct w n+      BlockDevice     _ _ -> putOct w n+      _                   -> replicate w '\NUL'++-- * TAR format primitive output++type FieldWidth = Int++putString :: FieldWidth -> String -> String+putString n s = take n s ++ fill (n - length s) '\NUL'++--TODO: check integer widths, eg for large file sizes+putOct :: Integral a => FieldWidth -> a -> String+putOct n x =+  let octStr = take (n-1) $ showOct x ""+   in fill (n - length octStr - 1) '0'+   ++ octStr+   ++ putChar8 '\NUL'++putChar8 :: Char -> String+putChar8 c = [c]++fill :: FieldWidth -> Char -> String+fill n c = replicate n c++--+-- * Unpacking+--++unpack :: FilePath -> Entries -> IO ()+unpack baseDir entries = unpackEntries [] (checkSecurity entries)+                     >>= emulateLinks++  where+    -- We're relying here on 'checkSecurity' to make sure we're not scribbling+    -- files all over the place.++    unpackEntries _     (Fail err)      = fail err+    unpackEntries links Done            = return links+    unpackEntries links (Next entry es) = case entryContent entry of+      NormalFile file _ -> extractFile entry path file+                        >> unpackEntries links es+      Directory         -> extractDir path+                        >> unpackEntries links es+      HardLink     link -> (unpackEntries $! saveLink path link links) es+      SymbolicLink link -> (unpackEntries $! saveLink path link links) es+      _                 -> unpackEntries links es --ignore other file types+      where+        path = entryPath entry++    extractFile entry path content = do+      -- Note that tar archives do not make sure each directory is created+      -- before files they contain, indeed we may have to create several+      -- levels of directory.+      createDirectoryIfMissing True absDir+      BS.writeFile absPath content+      when (isExecutable (entryPermissions entry))+           (setFileExecutable absPath)+      where+        absDir  = baseDir </> FilePath.Native.takeDirectory path+        absPath = baseDir </> path++    extractDir path = createDirectoryIfMissing True (baseDir </> path)++    saveLink path link links = seq (length path)+                             $ seq (length link')+                             $ (path, link'):links+      where link' = fromLinkTarget link++    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->+      let absPath   = baseDir </> relPath+          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget+       in copyFile absTarget absPath++--+-- * Packing+--++pack :: FilePath   -- ^ Base directory+     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir+     -> IO [Entry]+pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir++preparePaths :: FilePath -> [FilePath] -> IO [FilePath]+preparePaths baseDir paths =+  fmap concat $ interleave+    [ do isDir  <- doesDirectoryExist (baseDir </> path)+         if isDir+           then do entries <- getDirectoryContentsRecursive (baseDir </> path)+                   return (FilePath.Native.addTrailingPathSeparator path+                         : map (path </>) entries)+           else return [path]+    | path <- paths ]++packPaths :: FilePath -> [FilePath] -> IO [Entry]+packPaths baseDir paths =+  interleave+    [ do tarpath <- either fail return (toTarPath isDir relpath)+         if isDir then packDirectoryEntry filepath tarpath+                  else packFileEntry      filepath tarpath+    | relpath <- paths+    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath+          filepath = baseDir </> relpath ]++interleave :: [IO a] -> IO [a]+interleave = unsafeInterleaveIO . go+  where+    go []     = return []+    go (x:xs) = do+      x'  <- x+      xs' <- interleave xs+      return (x':xs')++packFileEntry :: FilePath -- ^ Full path to find the file on the local disk+              -> TarPath  -- ^ Path to use for the tar Entry in the archive+              -> IO Entry+packFileEntry filepath tarpath = do+  mtime   <- getModTime filepath+  perms   <- getPermissions filepath+  file    <- openBinaryFile filepath ReadMode+  size    <- hFileSize file+  content <- BS.hGetContents file+  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {+    entryPermissions = if Permissions.executable perms+                         then executableFilePermissions+                         else ordinaryFilePermissions,+    entryTime = mtime+  }++packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk+                   -> TarPath  -- ^ Path to use for the tar Entry in the archive+                   -> IO Entry+packDirectoryEntry filepath tarpath = do+  mtime   <- getModTime filepath+  return (directoryEntry tarpath) {+    entryTime = mtime+  }++getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive dir0 =+  fmap tail (recurseDirectories dir0 [""])++recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]+recurseDirectories _    []         = return []+recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do+  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)++  files' <- recurseDirectories base (dirs' ++ dirs)+  return (dir : files ++ files')++  where+    collect files dirs' []              = return (reverse files, reverse dirs')+    collect files dirs' (entry:entries) | ignore entry+                                        = collect files dirs' entries+    collect files dirs' (entry:entries) = do+      let dirEntry  = dir </> entry+          dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry+      isDirectory <- doesDirectoryExist (base </> dirEntry)+      if isDirectory+        then collect files (dirEntry':dirs') entries+        else collect (dirEntry:files) dirs' entries++    ignore ['.']      = True+    ignore ['.', '.'] = True+    ignore _          = False++getModTime :: FilePath -> IO EpochTime+getModTime path = do+  (TOD s _) <- getModificationTime path+  return $! fromIntegral s
+ Distribution/Client/Targets.hs view
@@ -0,0 +1,657 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Targets+-- Copyright   :  (c) Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified targets+-----------------------------------------------------------------------------+module Distribution.Client.Targets (+  -- * User targets+  UserTarget(..),+  readUserTargets,++  -- * Package specifiers+  PackageSpecifier(..),+  pkgSpecifierTarget,+  pkgSpecifierConstraints,++  -- * Resolving user targets to package specifiers+  resolveUserTargets,++  -- ** Detailed interface+  UserTargetProblem(..),+  readUserTarget,+  reportUserTargetProblems,+  expandUserTarget,++  PackageTarget(..),+  fetchPackageTarget,+  readPackageTarget,++  PackageTargetProblem(..),+  reportPackageTargetProblems,++  disambiguatePackageTargets,+  disambiguatePackageName,++  ) where++import Distribution.Package+         ( Package(..), PackageName(..)+         , PackageIdentifier(..), packageName, packageVersion+         , Dependency(Dependency) )+import Distribution.Client.Types+         ( AvailablePackage(..), PackageLocation(..) )+import Distribution.Client.Dependency.Types+         ( PackageConstraint(..) )++import qualified Distribution.Client.World as World+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Distribution.Client.Tar as Tar+import Distribution.Client.FetchUtils++import Distribution.PackageDescription+         ( GenericPackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription, parsePackageDescription, ParseResult(..) )+import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Client.Setup+         ( GlobalFlags(..) )+import Distribution.Version+         ( Version(Version), thisVersion, anyVersion, isAnyVersion )+import Distribution.Text+         ( Text(parse), display )+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+         ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )++import Data.List+         ( find, nub )+import Data.Maybe+         ( listToMaybe )+import Data.Either+         ( partitionEithers )+import Data.Monoid+         ( Monoid(..) )+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Distribution.Client.GZipUtils as GZipUtils+import Control.Monad (liftM)+import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, readP_to_S, (+++) )+import Data.Char+         ( isSpace )+import System.FilePath+         ( takeExtension, dropExtension, takeDirectory, splitPath )+import System.Directory+         ( doesFileExist, doesDirectoryExist )+import Network.URI+         ( URI(..), URIAuth(..), parseAbsoluteURI )++-- ------------------------------------------------------------+-- * User targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a package or package collection.+--+data UserTarget =++     -- | A partially specified package, identified by name and possibly with+     -- an exact version or a version constraint.+     --+     -- > cabal install foo+     -- > cabal install foo-1.0+     -- > cabal install 'foo < 2'+     --+     UserTargetNamed Dependency++     -- | A special virtual package that refers to the collection of packages+     -- recorded in the world file that the user specifically installed.+     --+     -- > cabal install world+     --+   | UserTargetWorld++     -- | A specific package that is unpacked in a local directory, often the+     -- current directory.+     --+     -- > cabal install .+     -- > cabal install ../lib/other+     --+     -- * Note: in future, if multiple @.cabal@ files are allowed in a single+     -- directory then this will refer to the collection of packages.+     --+   | UserTargetLocalDir FilePath++     -- | A specific local unpacked package, identified by its @.cabal@ file.+     --+     -- > cabal install foo.cabal+     -- > cabal install ../lib/other/bar.cabal+     --+   | UserTargetLocalCabalFile FilePath++     -- | A specific package that is available as a local tarball file+     --+     -- > cabal install dist/foo-1.0.tar.gz+     -- > cabal install ../build/baz-1.0.tar.gz+     --+   | UserTargetLocalTarball FilePath++     -- | A specific package that is available as a remote tarball file+     --+     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz+     --+   | UserTargetRemoteTarball URI+  deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Package specifier+-- ------------------------------------------------------------++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++     -- | A partially specified reference to a package (either source or+     -- installed). It is specified by package name and optionally some+     -- additional constraints. Use a dependency resolver to pick a specific+     -- package satisfying these constraints.+     --+     NamedPackage PackageName [PackageConstraint]++     -- | A fully specified source package.+     --+   | SpecificSourcePackage pkg+  deriving Show+++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _)       = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+                        => PackageSpecifier pkg -> [PackageConstraint]+pkgSpecifierConstraints (NamedPackage _ constraints) = constraints+pkgSpecifierConstraints (SpecificSourcePackage pkg)  =+  [PackageVersionConstraint (packageName pkg)+                            (thisVersion (packageVersion pkg))]+++-- ------------------------------------------------------------+-- * Parsing and checking user targets+-- ------------------------------------------------------------++readUserTargets :: Verbosity -> [String] -> IO [UserTarget]+readUserTargets _verbosity targetStrs = do+    (problems, targets) <- liftM partitionEithers+                                 (mapM readUserTarget targetStrs)+    reportUserTargetProblems problems+    return targets+++data UserTargetProblem+   = UserTargetUnexpectedFile      String+   | UserTargetNonexistantFile     String+   | UserTargetUnexpectedUriScheme String+   | UserTargetUnrecognisedUri     String+   | UserTargetUnrecognised        String+   | UserTargetBadWorldPkg+  deriving Show++readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)+readUserTarget targetstr =+    case testNamedTargets targetstr of+      Just (Dependency (PackageName "world") verrange)+        | verrange == anyVersion -> return (Right UserTargetWorld)+        | otherwise              -> return (Left  UserTargetBadWorldPkg)+      Just dep                   -> return (Right (UserTargetNamed dep))+      Nothing -> do+        fileTarget <- testFileTargets targetstr+        case fileTarget of+          Just target -> return target+          Nothing     ->+            case testUriTargets targetstr of+              Just target -> return target+              Nothing     -> return (Left (UserTargetUnrecognised targetstr))+  where+    testNamedTargets = readPToMaybe parseDependencyOrPackageId++    testFileTargets filename = do+      isDir  <- doesDirectoryExist filename+      isFile <- doesFileExist filename+      parentDirExists <- case takeDirectory filename of+                           []  -> return False+                           dir -> doesDirectoryExist dir+      let result+            | isDir+            = Just (Right (UserTargetLocalDir filename))++            | isFile && extensionIsTarGz filename+            = Just (Right (UserTargetLocalTarball filename))++            | isFile && takeExtension filename == ".cabal"+            = Just (Right (UserTargetLocalCabalFile filename))++            | isFile+            = Just (Left (UserTargetUnexpectedFile filename))++            | parentDirExists+            = Just (Left (UserTargetNonexistantFile filename))++            | otherwise+            = Nothing+      return result++    testUriTargets str =+      case parseAbsoluteURI str of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host }+          }+          | scheme /= "http:" ->+            Just (Left (UserTargetUnexpectedUriScheme targetstr))++          | null host ->+            Just (Left (UserTargetUnrecognisedUri targetstr))++          | otherwise ->+            Just (Right (UserTargetRemoteTarball uri))+        _ -> Nothing++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"++    parseDependencyOrPackageId :: Parse.ReadP r Dependency+    parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+      where+        pkgidToDependency :: PackageIdentifier -> Dependency+        pkgidToDependency p = case packageVersion p of+          Version [] _ -> Dependency (packageName p) anyVersion+          version      -> Dependency (packageName p) (thisVersion version)++    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                         , all isSpace s ]+++reportUserTargetProblems :: [UserTargetProblem] -> IO ()+reportUserTargetProblems problems = do+    case [ target | UserTargetUnrecognised target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognised target '" ++ name ++ "'."+                  | name <- target ]+             ++ "Targets can be:\n"+             ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"+             ++ " - the special 'world' target\n"+             ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"+             ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"++    case [ () | UserTargetBadWorldPkg <- problems ] of+      [] -> return ()+      _  -> die "The special 'world' target does not take any version."++    case [ target | UserTargetNonexistantFile target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "The file does not exist '" ++ name ++ "'."+                  | name <- target ]++    case [ target | UserTargetUnexpectedFile target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognised file target '" ++ name ++ "'."+                  | name <- target ]+             ++ "File targets can be either package tarballs 'pkgname.tar.gz' "+             ++ "or cabal files 'pkgname.cabal'."++    case [ target | UserTargetUnexpectedUriScheme target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "URL target not supported '" ++ name ++ "'."+                  | name <- target ]+             ++ "Only 'http://' URLs are supported."++    case [ target | UserTargetUnrecognisedUri target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognise URL target '" ++ name ++ "'."+                  | name <- target ]+++-- ------------------------------------------------------------+-- * Resolving user targets to package specifiers+-- ------------------------------------------------------------++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to. They can either be specific packages (local dirs, tarballs etc)+-- or they can be named packages (with or without version info).+--+resolveUserTargets :: Package pkg+                   => Verbosity+                   -> GlobalFlags+                   -> PackageIndex pkg+                   -> [UserTarget]+                   -> IO [PackageSpecifier AvailablePackage]+resolveUserTargets verbosity globalFlags available userTargets = do++    -- given the user targets, get a list of fully or partially resolved+    -- package references+    packageTargets <- mapM (readPackageTarget verbosity)+                  =<< mapM (fetchPackageTarget verbosity) . concat+                  =<< mapM (expandUserTarget globalFlags) userTargets++    -- users are allowed to give package names case-insensitively, so we must+    -- disambiguate named package references+    let (problems, packageSpecifiers) =+           disambiguatePackageTargets available availableExtra packageTargets++        -- use any extra specific available packages to help us disambiguate+        availableExtra = [ packageName pkg+                         | PackageTargetLocation pkg <- packageTargets ]++    reportPackageTargetProblems verbosity problems++    return packageSpecifiers+++-- ------------------------------------------------------------+-- * Package targets+-- ------------------------------------------------------------++-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.+-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.+--+data PackageTarget pkg =+     PackageTargetNamed      PackageName [PackageConstraint] UserTarget++     -- | A package identified by name, but case insensitively, so it needs+     -- to be resolved to the right case-sensitive name.+   | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget+   | PackageTargetLocation pkg+  deriving Show+++-- ------------------------------------------------------------+-- * Converting user targets to package targets+-- ------------------------------------------------------------++-- | Given a user-specified target, expand it to a bunch of package targets+-- (each of which refers to only one package).+--+expandUserTarget :: GlobalFlags+                 -> UserTarget+                 -> IO [PackageTarget (PackageLocation ())]+expandUserTarget globalFlags userTarget = case userTarget of++    UserTargetNamed (Dependency name vrange) ->+      let constraints = [ PackageVersionConstraint name vrange+                        | not (isAnyVersion vrange) ]+      in  return [PackageTargetNamedFuzzy name constraints userTarget]++    UserTargetWorld -> do+      worldPkgs <- World.getContents worldFile+      --TODO: should we warn if there are no world targets?+      return [ PackageTargetNamed name constraints userTarget+             | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs+             , let constraints = [ PackageVersionConstraint name vrange+                                 | not (isAnyVersion vrange) ]+                              ++ [ PackageFlagsConstraint name flags+                                 | not (null flags) ] ]++    UserTargetLocalDir dir ->+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalCabalFile file -> do+      let dir = takeDirectory file+      _   <- findPackageDesc dir -- just as a check+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalTarball tarballFile ->+      return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]++    UserTargetRemoteTarball tarballURL ->+      return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]+  where+    worldFile = fromFlag $ globalWorldFile globalFlags+++-- ------------------------------------------------------------+-- * Fetching and reading package targets+-- ------------------------------------------------------------+++-- | Fetch any remote targets so that they can be read.+--+fetchPackageTarget :: Verbosity+                   -> PackageTarget (PackageLocation ())+                   -> IO (PackageTarget (PackageLocation FilePath))+fetchPackageTarget verbosity target = case target of+    PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)+    PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)+    PackageTargetLocation location  -> do+      location' <- fetchPackage verbosity (fmap (const Nothing) location)+      return (PackageTargetLocation location')+++-- | Given a package target that has been fetched, read the .cabal file.+--+-- This only affects targets given by location, named targets are unaffected.+--+readPackageTarget :: Verbosity+                  -> PackageTarget (PackageLocation FilePath)+                  -> IO (PackageTarget AvailablePackage)+readPackageTarget verbosity target = case target of++    PackageTargetNamed pkgname constraints userTarget ->+      return (PackageTargetNamed pkgname constraints userTarget)++    PackageTargetNamedFuzzy pkgname constraints userTarget ->+      return (PackageTargetNamedFuzzy pkgname constraints userTarget)++    PackageTargetLocation location -> case location of++      LocalUnpackedPackage dir -> do+        pkg <- readPackageDescription verbosity =<< findPackageDesc dir+        return $ PackageTargetLocation $+                   AvailablePackage {+                     packageInfoId      = packageId pkg,+                     packageDescription = pkg,+                     packageSource      = fmap Just location+                   }++      LocalTarballPackage tarballFile ->+        readTarballPackageTarget location tarballFile tarballFile++      RemoteTarballPackage tarballURL tarballFile ->+        readTarballPackageTarget location tarballFile (show tarballURL)++      RepoTarballPackage _repo _pkgid _ ->+        error "TODO: readPackageTarget RepoTarballPackage"+        -- For repo tarballs this info should be obtained from the index.++  where+    readTarballPackageTarget location tarballFile tarballOriginalLoc = do+      (filename, content) <- extractTarballPackageCabalFile+                               tarballFile tarballOriginalLoc+      case parsePackageDescription' content of+        Nothing  -> die $ "Could not parse the cabal file "+                       ++ filename ++ " in " ++ tarballFile+        Just pkg ->+          return $ PackageTargetLocation $+                     AvailablePackage {+                       packageInfoId      = packageId pkg,+                       packageDescription = pkg,+                       packageSource      = fmap Just location+                     }++    extractTarballPackageCabalFile :: FilePath -> String+                                   -> IO (FilePath, BS.ByteString)+    extractTarballPackageCabalFile tarballFile tarballOriginalLoc =+          either (die . formatErr) return+        . check+        . Tar.entriesIndex+        . Tar.filterEntries isCabalFile+        . Tar.read+        . GZipUtils.maybeDecompress+      =<< BS.readFile tarballFile+      where+        formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg++        check (Left e)  = Left e+        check (Right m) = case Map.elems m of+            []     -> Left noCabalFile+            [file] -> case Tar.entryContent file of+              Tar.NormalFile content _ -> Right (Tar.entryPath file, content)+              _                        -> Left noCabalFile+            _files -> Left multipleCabalFiles+          where+            noCabalFile        = "No cabal file found"+            multipleCabalFiles = "Multiple cabal files found"++        isCabalFile e = case splitPath (Tar.entryPath e) of+          [     _dir, file] -> takeExtension file == ".cabal"+          [".", _dir, file] -> takeExtension file == ".cabal"+          _                 -> False++    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription+    parsePackageDescription' content =+      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+        ParseOk _ pkg -> Just pkg+        _             -> Nothing+++-- ------------------------------------------------------------+-- * Checking package targets+-- ------------------------------------------------------------++data PackageTargetProblem+   = PackageNameUnknown   PackageName               UserTarget+   | PackageNameAmbigious PackageName [PackageName] UserTarget+  deriving Show+++-- | Users are allowed to give package names case-insensitively, so we must+-- disambiguate named package references.+--+disambiguatePackageTargets :: Package pkg'+                           => PackageIndex pkg'+                           -> [PackageName]+                           -> [PackageTarget pkg]+                           -> ( [PackageTargetProblem]+                              , [PackageSpecifier pkg] )+disambiguatePackageTargets available availableExtra targets =+    partitionEithers (map disambiguatePackageTarget targets)+  where+    disambiguatePackageTarget packageTarget = case packageTarget of+      PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)++      PackageTargetNamed pkgname constraints userTarget+        | null (PackageIndex.lookupPackageName available pkgname)+                    -> Left (PackageNameUnknown pkgname userTarget)+        | otherwise -> Right (NamedPackage pkgname constraints)++      PackageTargetNamedFuzzy pkgname constraints userTarget ->+        case disambiguatePackageName packageNameEnv pkgname of+          None                 -> Left  (PackageNameUnknown+                                          pkgname userTarget)+          Ambiguous   pkgnames -> Left  (PackageNameAmbigious+                                          pkgname pkgnames userTarget)+          Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints)++    -- use any extra specific available packages to help us disambiguate+    packageNameEnv :: PackageNameEnv+    packageNameEnv = mappend (indexPackageNameEnv available)+                             (extraPackageNameEnv availableExtra)+++-- | Report problems to the user. That is, if there are any problems+-- then raise an exception.+reportPackageTargetProblems :: Verbosity+                            -> [PackageTargetProblem] -> IO ()+reportPackageTargetProblems verbosity problems = do+    case [ pkg | PackageNameUnknown pkg originalTarget <- problems+               , not (isUserTagetWorld originalTarget) ] of+      []    -> return ()+      pkgs  -> die $ unlines+                       [ "There is no package named '" ++ display name ++ "'. "+                       | name <- pkgs ]+                  ++ "You may need to run 'cabal update' to get the latest "+                  ++ "list of available packages."++    case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of+      []          -> return ()+      ambiguities -> die $ unlines+                             [    "The package name '" ++ display name+                               ++ "' is ambigious. It could be: "+                               ++ intercalate ", " (map display matches)+                             | (name, matches) <- ambiguities ]++    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of+      []   -> return ()+      pkgs -> warn verbosity $+                 "The following 'world' packages will be ignored because "+              ++ "they refer to packages that cannot be found: "+              ++ intercalate ", " (map display pkgs) ++ "\n"+              ++ "You can surpress this warning by correcting the world file."+  where+    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False+++-- ------------------------------------------------------------+-- * Disambiguating package names+-- ------------------------------------------------------------++data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]++-- | Given a package name and a list of matching names, figure out which one it+-- might be referring to. If there is an exact case-sensitive match then that's+-- ok. If it matches just one package case-insensitively then that's also ok.+-- The only problem is if it matches multiple packages case-insensitively, in+-- that case it is ambigious.+--+disambiguatePackageName :: PackageNameEnv+                        -> PackageName+                        -> MaybeAmbigious PackageName+disambiguatePackageName (PackageNameEnv pkgNameLookup) name =+    case nub (pkgNameLookup name) of+      []      -> None+      [name'] -> Unambiguous name'+      names   -> case find (name==) names of+                   Just name' -> Unambiguous name'+                   Nothing    -> Ambiguous names+++newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])++instance Monoid PackageNameEnv where+  mempty = PackageNameEnv (const [])+  mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =+    PackageNameEnv (\name -> lookupA name ++ lookupB name)++indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv index = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup (PackageName name) =+      map fst (PackageIndex.searchByName index name)++extraPackageNameEnv :: [PackageName] -> PackageNameEnv+extraPackageNameEnv names = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup (PackageName name) =+      [ PackageName name'+      | let lname = lowercase name+      , PackageName name' <- names+      , lowercase name' == lname ]
+ Distribution/Client/Types.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Types+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Various common data types for the entire cabal-install system+-----------------------------------------------------------------------------+module Distribution.Client.Types where++import Distribution.Package+         ( PackageName, PackageId, Package(..), PackageFixedDeps(..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.PackageDescription+         ( GenericPackageDescription, FlagAssignment )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import Distribution.Version+         ( VersionRange )++import Data.Map (Map)+import Network.URI (URI)+import Distribution.Compat.Exception+         ( SomeException )++newtype Username = Username { unUsername :: String }+newtype Password = Password { unPassword :: String }++-- | This is the information we get from a @00-index.tar.gz@ hackage index.+--+data AvailablePackageDb = AvailablePackageDb {+  packageIndex       :: PackageIndex AvailablePackage,+  packagePreferences :: Map PackageName VersionRange+}++-- ------------------------------------------------------------+-- * Various kinds of information about packages+-- ------------------------------------------------------------++-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.+-- What is new in 1.8 is that installed packages and dependencies between+-- installed packages are now identified by an opaque InstalledPackageId+-- rather than a source PackageId.+--+-- We should use simply an 'InstalledPackageInfo' here but to ease the+-- transition we are temporarily using this variant where we pretend that+-- installed packages still specify their deps in terms of PackageIds.+--+-- Crucially this means that 'InstalledPackage' can be an instance of+-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance+-- of that class. This means we can make 'PackageIndex'es of InstalledPackage+-- where as the InstalledPackageInfo now has its own monomorphic index type.+--+data InstalledPackage = InstalledPackage+       InstalledPackageInfo+       [PackageId]++instance Package InstalledPackage where+  packageId (InstalledPackage pkg _) = packageId pkg+instance PackageFixedDeps InstalledPackage where+  depends (InstalledPackage _ deps) = deps++-- | A 'ConfiguredPackage' is a not-yet-installed package along with the+-- total configuration information. The configuration information is total in+-- the sense that it provides all the configuration information and so the+-- final configure process will be independent of the environment.+--+data ConfiguredPackage = ConfiguredPackage+       AvailablePackage    -- package info, including repo+       FlagAssignment      -- complete flag assignment for the package+       [PackageId]         -- set of exact dependencies. These must be+                           -- consistent with the 'buildDepends' in the+                           -- 'PackageDescrption' that you'd get by applying+                           -- the flag assignment.+  deriving Show++instance Package ConfiguredPackage where+  packageId (ConfiguredPackage pkg _ _) = packageId pkg++instance PackageFixedDeps ConfiguredPackage where+  depends (ConfiguredPackage _ _ deps) = deps+++-- | We re-use @GenericPackageDescription@ and use the @package-url@+-- field to store the tarball URI.+data AvailablePackage = AvailablePackage {+    packageInfoId      :: PackageId,+    packageDescription :: GenericPackageDescription,+    packageSource      :: PackageLocation (Maybe FilePath)+  }+  deriving Show++instance Package AvailablePackage where packageId = packageInfoId++-- ------------------------------------------------------------+-- * Package locations and repositories+-- ------------------------------------------------------------++data PackageLocation local =++    -- | An unpacked package in the given dir, or current dir+    LocalUnpackedPackage FilePath++    -- | A package as a tarball that's available as a local tarball+  | LocalTarballPackage FilePath++    -- | A package as a tarball from a remote URI+  | RemoteTarballPackage URI local++    -- | A package available as a tarball from a repository.+    --+    -- It may be from a local repository or from a remote repository, with a+    -- locally cached copy. ie a package available from hackage+  | RepoTarballPackage Repo PackageId local++--TODO:+--  * add support for darcs and other SCM style remote repos with a local cache+--  | ScmPackage+  deriving Show++instance Functor PackageLocation where+  fmap _ (LocalUnpackedPackage dir)      = LocalUnpackedPackage dir+  fmap _ (LocalTarballPackage  file)     = LocalTarballPackage  file+  fmap f (RemoteTarballPackage uri x)    = RemoteTarballPackage uri    (f x)+  fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x)+++data LocalRepo = LocalRepo+  deriving (Show,Eq)++data RemoteRepo = RemoteRepo {+    remoteRepoName :: String,+    remoteRepoURI  :: URI+  }+  deriving (Show,Eq)++data Repo = Repo {+    repoKind     :: Either RemoteRepo LocalRepo,+    repoLocalDir :: FilePath+  }+  deriving (Show,Eq)++-- ------------------------------------------------------------+-- * Build results+-- ------------------------------------------------------------++type BuildResult  = Either BuildFailure BuildSuccess+data BuildFailure = DependentFailed PackageId+                  | DownloadFailed  SomeException+                  | UnpackFailed    SomeException+                  | ConfigureFailed SomeException+                  | BuildFailed     SomeException+                  | InstallFailed   SomeException+data BuildSuccess = BuildOk         DocsResult TestsResult++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+data TestsResult = TestsNotTried | TestsFailed | TestsOk
+ Distribution/Client/Unpack.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Unpack+-- Copyright   :  (c) Andrea Vezzosi 2008+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Unpack (++    -- * Commands+    unpack,++  ) where++import Distribution.Package+         ( PackageId, packageId )+import Distribution.Simple.Setup+         ( fromFlagOrDefault )+import Distribution.Simple.Utils+         ( notice, die )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text(display)++import Distribution.Client.Setup+         ( GlobalFlags(..), UnpackFlags(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils as IndexUtils+        ( getAvailablePackages )++import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )+import Control.Monad+         ( unless, when )+import Data.Monoid+         ( mempty )+import System.FilePath+         ( (</>), addTrailingPathSeparator )+++unpack :: Verbosity+       -> [Repo]+       -> GlobalFlags+       -> UnpackFlags+       -> [UserTarget] +       -> IO ()+unpack verbosity _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++unpack verbosity repos globalFlags unpackFlags userTargets = do+  mapM_ checkTarget userTargets++  availableDb   <- getAvailablePackages verbosity repos++  pkgSpecifiers <- resolveUserTargets verbosity+                     globalFlags (packageIndex availableDb) userTargets++  pkgs <- either (die . unlines . map show) return $+            resolveWithoutDependencies+              (resolverParams availableDb pkgSpecifiers)++  unless (null prefix) $+         createDirectoryIfMissing True prefix++  flip mapM_ pkgs $ \pkg -> do+    location <- fetchPackage verbosity (packageSource pkg)+    let pkgid = packageId pkg+    case location of+      LocalTarballPackage tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      RemoteTarballPackage _tarballURL tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      RepoTarballPackage _repo _pkgid tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      LocalUnpackedPackage _ ->+        error "Distribution.Client.Unpack.unpack: the impossible happened."++  where+    resolverParams availableDb pkgSpecifiers =+        --TODO: add commandline constraint and preference args for unpack++        standardInstallPolicy mempty availableDb pkgSpecifiers++    prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetLocalDir       dir  -> die (notTarball dir)+    UserTargetLocalCabalFile file -> die (notTarball file)+    _                             -> return ()+  where+    notTarball t =+        "The 'unpack' command is for tarball packages. "+     ++ "The target '" ++ t ++ "' is not a tarball."++unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()+unpackPackage verbosity prefix pkgid pkgPath = do+    let pkgdirname = display pkgid+        pkgdir     = prefix </> pkgdirname+        pkgdir'    = addTrailingPathSeparator pkgdir+    existsDir  <- doesDirectoryExist pkgdir+    when existsDir $ die $+     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."+    existsFile  <- doesFileExist pkgdir+    when existsFile $ die $+     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."+    notice verbosity $ "Unpacking to " ++ pkgdir'+    Tar.extractTarGzFile prefix pkgdirname pkgPath
+ Distribution/Client/Update.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Update+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Update+    ( update+    ) where++import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )+import Distribution.Client.FetchUtils+         ( downloadIndex )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.IndexUtils+         ( getAvailablePackages )+import qualified Paths_cabal_install_bundle+         ( version )++import Distribution.Package+         ( PackageName(..), packageVersion )+import Distribution.Version+         ( anyVersion, withinRange )+import Distribution.Simple.Utils+         ( warn, notice, writeFileAtomic )+import Distribution.Verbosity+         ( Verbosity )++import qualified Data.ByteString.Lazy       as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Distribution.Client.GZipUtils (maybeDecompress)+import qualified Data.Map as Map+import System.FilePath (dropExtension)+import Data.Maybe      (fromMaybe)+import Control.Monad   (when)++-- | 'update' downloads the package list from all known servers+update :: Verbosity -> [Repo] -> IO ()+update verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+update verbosity repos = do+  mapM_ (updateRepo verbosity) repos+  checkForSelfUpgrade verbosity repos++updateRepo :: Verbosity -> Repo -> IO ()+updateRepo verbosity repo = case repoKind repo of+  Right LocalRepo -> return ()+  Left remoteRepo -> do+    notice verbosity $ "Downloading the latest package list from "+                    ++ remoteRepoName remoteRepo+    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack+                                              . maybeDecompress+                                            =<< BS.readFile indexPath++checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()+checkForSelfUpgrade verbosity repos = do+  AvailablePackageDb available prefs <- getAvailablePackages verbosity repos++  let self = PackageName "cabal-install"+      preferredVersionRange  = fromMaybe anyVersion (Map.lookup self prefs)+      currentVersion         = Paths_cabal_install_bundle.version+      laterPreferredVersions =+        [ packageVersion pkg+        | pkg <- PackageIndex.lookupPackageName available self+        , let version = packageVersion pkg+        , version > currentVersion+        , version `withinRange` preferredVersionRange ]++  when (not (null laterPreferredVersions)) $+    notice verbosity $+         "Note: there is a new version of cabal-install available.\n"+      ++ "To upgrade, run: cabal install cabal-install"
+ Distribution/Client/Upload.hs view
@@ -0,0 +1,190 @@+-- This is a quick hack for uploading packages to Hackage.+-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload++module Distribution.Client.Upload (check, upload, report) where++import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))+import Distribution.Client.HttpUtils (proxy, isOldHackageURI)++import Distribution.Simple.Utils (debug, notice, warn, info)+import Distribution.Verbosity (Verbosity)+import Distribution.Text (display)+import Distribution.Client.Config++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import qualified Distribution.Client.BuildReports.Upload as BuildReport++import Network.Browser+         ( BrowserAction, browse, request+         , Authority(..), addAuthority, setAuthorityGen+         , setOutHandler, setErrHandler, setProxy )+import Network.HTTP+         ( Header(..), HeaderName(..), findHeader+         , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream)+import Network.URI (URI(uriPath), parseURI)++import Data.Char        (intToDigit)+import Numeric          (showHex)+import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho+                        ,openBinaryFile, IOMode(ReadMode), hGetContents)+import Control.Exception (bracket)+import System.Random    (randomRIO)+import System.FilePath  ((</>), takeExtension, takeFileName)+import qualified System.FilePath.Posix as FilePath.Posix (combine)+import System.Directory+import Control.Monad (forM_)+++--FIXME: how do we find this path for an arbitrary hackage server?+-- is it always at some fixed location relative to the server root?+legacyUploadURI :: URI+Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"++checkURI :: URI+Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"+++upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()+upload verbosity repos mUsername mPassword paths = do+          let uploadURI = if isOldHackageURI targetRepoURI+                          then legacyUploadURI+                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}+          Username username <- maybe promptUsername return mUsername+          Password password <- maybe promptPassword return mPassword+          let auth = addAuthority AuthBasic {+                       auRealm    = "Hackage",+                       auUsername = username,+                       auPassword = password,+                       auSite     = uploadURI+                     }+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Uploading " ++ path ++ "... "+            handlePackage verbosity uploadURI auth path+  where+    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given++promptUsername :: IO Username+promptUsername = do+  putStr "Hackage username: "+  hFlush stdout+  fmap Username getLine++promptPassword :: IO Password+promptPassword = do+  putStr "Hackage password: "+  hFlush stdout+  -- save/restore the terminal echoing status+  passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+    hSetEcho stdin False  -- no echoing for entering the password+    fmap Password getLine+  putStrLn ""+  return passwd++report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()+report verbosity repos mUsername mPassword = do+      let uploadURI = if isOldHackageURI targetRepoURI+                      then legacyUploadURI+                      else targetRepoURI{uriPath = ""}+      Username username <- maybe promptUsername return mUsername+      Password password <- maybe promptPassword return mPassword+      let auth = addAuthority AuthBasic {+                   auRealm    = "Hackage",+                   auUsername = username,+                   auPassword = password,+                   auSite     = uploadURI+                 }+      forM_ repos $ \repo -> case repoKind repo of+        Left remoteRepo+            -> do dotCabal <- defaultCabalDir+                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+                  contents <- getDirectoryContents srcDir+                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->+                      do inp <- readFile (srcDir </> logFile)+                         let (reportStr, buildLog) = read inp :: (String,String)+                         case BuildReport.parse reportStr of+                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME+                           Right report' ->+                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')+                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth+                                  return ()+        Right{} -> return ()+  where+    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given++check :: Verbosity -> [FilePath] -> IO ()+check verbosity paths = do+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Checking " ++ path ++ "... "+            handlePackage verbosity checkURI (return ()) path++handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()+              -> FilePath -> IO ()+handlePackage verbosity uri auth path =+  do req <- mkRequest uri path+     p   <- proxy verbosity+     debug verbosity $ "\n" ++ show req+     (_,resp) <- browse $ do+                   setProxy p+                   setErrHandler (warn verbosity . ("http error: "++))+                   setOutHandler (debug verbosity)+                   auth+                   setAuthorityGen (\_ _ -> return Nothing)+                   request req+     debug verbosity $ show resp+     case rspCode resp of+       (2,0,0) -> do notice verbosity "Ok"+       (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "+                                     ++ map intToDigit [x,y,z] ++ " "+                                     ++ rspReason resp+                     case findHeader HdrContentType resp of+                       Just contenttype+                         | takeWhile (/= ';') contenttype == "text/plain"+                         -> notice verbosity $ rspBody resp+                       _ -> debug verbosity $ rspBody resp++mkRequest :: URI -> FilePath -> IO (Request String)+mkRequest uri path = +    do pkg <- readBinaryFile path+       boundary <- genBoundary+       let body = printMultiPart boundary (mkFormData path pkg)+       return $ Request {+                         rqURI = uri,+                         rqMethod = POST,+                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),+                                      Header HdrContentLength (show (length body)),+                                      Header HdrAccept ("text/plain")],+                         rqBody = body+                        }++readBinaryFile :: FilePath -> IO String+readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents++genBoundary :: IO String+genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+                 return $ showHex i ""++mkFormData :: FilePath -> String -> [BodyPart]+mkFormData path pkg =+  -- yes, web browsers are that stupid (re quoting)+  [BodyPart [Header hdrContentDisposition $+             "form-data; name=package; filename=\""++takeFileName path++"\"",+             Header HdrContentType "application/x-gzip"]+   pkg]++hdrContentDisposition :: HeaderName+hdrContentDisposition = HdrCustom "Content-disposition"++-- * Multipart, partly stolen from the cgi package.++data BodyPart = BodyPart [Header] String++printMultiPart :: String -> [BodyPart] -> String+printMultiPart boundary xs = +    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf++printBodyPart :: String -> BodyPart -> String+printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c++crlf :: String+crlf = "\r\n"
+ Distribution/Client/Utils.hs view
@@ -0,0 +1,60 @@+module Distribution.Client.Utils where++import Data.List+         ( sortBy, groupBy )+import System.Directory+         ( doesFileExist, getModificationTime+         , getCurrentDirectory, setCurrentDirectory )+import qualified Control.Exception as Exception+         ( finally )++-- | Generic merging utility. For sorted input lists this is a full outer join.+--+-- * The result list never contains @(Nothing, Nothing)@.+--+mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy cmp = merge+  where+    merge []     ys     = [ OnlyInRight y | y <- ys]+    merge xs     []     = [ OnlyInLeft  x | x <- xs]+    merge (x:xs) (y:ys) =+      case x `cmp` y of+        GT -> OnlyInRight   y : merge (x:xs) ys+        EQ -> InBoth      x y : merge xs     ys+        LT -> OnlyInLeft  x   : merge xs  (y:ys)++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b++duplicates :: Ord a => [a] -> [[a]]+duplicates = duplicatesBy compare++duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]+duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp+  where+    eq a b = case cmp a b of+               EQ -> True+               _  -> False+    moreThanOne (_:_:_) = True+    moreThanOne _       = False++-- | Compare the modification times of two files to see if the first is newer+-- than the second. The first file must exist but the second need not.+-- The expected use case is when the second file is generated using the first.+-- In this use case, if the result is True then the second file is out of date.+--+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModificationTime b+            ta <- getModificationTime a+            return (ta > tb)++-- | Executes the action in the specified directory.+inDir :: Maybe FilePath -> IO () -> IO ()+inDir Nothing m = m+inDir (Just d) m = do+  old <- getCurrentDirectory+  setCurrentDirectory d+  m `Exception.finally` setCurrentDirectory old
+ Distribution/Client/Win32SelfUpgrade.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Win32SelfUpgrade+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Support for self-upgrading executables on Windows platforms.+-----------------------------------------------------------------------------+module Distribution.Client.Win32SelfUpgrade (+-- * Explanation+--+-- | Windows inherited a design choice from DOS that while initially innocuous+-- has rather unfortunate consequences. It maintains the invariant that every+-- open file has a corresponding name on disk. One positive consequence of this+-- is that an executable can always find it's own executable file. The downside+-- is that a program cannot be deleted or upgraded while it is running without+-- hideous workarounds. This module implements one such hideous workaround.+--+-- The basic idea is:+--+-- * Move our own exe file to a new name+-- * Copy a new exe file to the previous name+-- * Run the new exe file, passing our own pid and new path+-- * Wait for the new process to start+-- * Close the new exe file+-- * Exit old process+--+-- Then in the new process:+--+-- * Inform the old process that we've started+-- * Wait for the old process to die+-- * Delete the old exe file+-- * Exit new process+--++    possibleSelfUpgrade,+    deleteOldExeFile,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import qualified System.Win32 as Win32+import qualified System.Win32.DLL as Win32+import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)+import Foreign.Ptr (Ptr, nullPtr)+import System.Process (runProcess)+import System.Directory (canonicalizePath)+import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)++import Distribution.Verbosity as Verbosity (Verbosity, showForCabal)+import Distribution.Simple.Utils (debug, info)++import Prelude hiding (log)++-- | If one of the given files is our own exe file then we arrange things such+-- that the nested action can replace our own exe file.+--+-- We require that the new process accepts a command line invocation that+-- calls 'deleteOldExeFile', passing in the pid and exe file.+--+possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade verbosity newPaths action = do+  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE++  newPaths' <- mapM canonicalizePath newPaths+  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'++  if not doingSelfUpgrade+    then action+    else do+      info verbosity $ "cabal-install does the replace-own-exe-file dance..."+      tmpPath <- moveOurExeOutOfTheWay verbosity+      result <- action+      scheduleOurDemise verbosity dstPath tmpPath+        (\pid path -> ["win32selfupgrade", pid, path+                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])+      return result++-- | The name of a Win32 Event object that we use to synchronise between the+-- old and new processes. We need to synchronise to make sure that the old+-- process has not yet terminated by the time the new one starts up and looks+-- for the old process. Otherwise the old one might have already terminated+-- and we could not wait on it terminating reliably (eg the pid might get+-- re-used).+--+syncEventName :: String+syncEventName = "Local\\cabal-install-upgrade"++-- | The first part of allowing our exe file to be replaced is to move the+-- existing exe file out of the way. Although we cannot delete our exe file+-- while we're still running, fortunately we can rename it, at least within+-- the same directory.+--+moveOurExeOutOfTheWay :: Verbosity -> IO FilePath+moveOurExeOutOfTheWay verbosity = do+  ourPID  <-       getCurrentProcessId+  dstPath <- Win32.getModuleFileName Win32.nullHANDLE++  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)++  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath+  Win32.moveFile dstPath tmpPath+  return tmpPath++-- | Assuming we've now installed the new exe file in the right place, we+-- launch it and ask it to delete our exe file when we eventually terminate.+--+scheduleOurDemise :: Verbosity -> FilePath -> FilePath+                  -> (String -> FilePath -> [String]) -> IO ()+scheduleOurDemise verbosity dstPath tmpPath mkArgs = do+  ourPID <- getCurrentProcessId+  event  <- createEvent syncEventName++  let args = mkArgs (show ourPID) tmpPath+  log $ "launching child " ++ unwords (dstPath : map show args)+  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing++  log $ "waiting for the child to start up"+  waitForSingleObject event (10*1000) -- wait at most 10 sec+  log $ "child started ok"++  where+    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)++-- | Assuming we're now in the new child process, we've been asked by the old+-- process to wait for it to terminate and then we can remove the old exe file+-- that it renamted itself to.+--+deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile verbosity oldPID tmpPath = do+  log $ "process started. Will delete exe file of process "+     ++ show oldPID ++ " at path " ++ tmpPath++  log $ "getting handle of parent process " ++ show oldPID+  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)++  log $ "synchronising with parent"+  event <- openEvent syncEventName+  setEvent event++  log $ "waiting for parent process to terminate"+  waitForSingleObject oldPHANDLE Win32.iNFINITE+  log $ "parent process terminated"++  log $ "deleting parent's old .exe file"+  Win32.deleteFile tmpPath++  where+    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)++------------------------+-- Win32 foreign imports+--++-- A bunch of functions sadly not provided by the Win32 package.++foreign import stdcall unsafe "windows.h GetCurrentProcessId"+  getCurrentProcessId :: IO DWORD++foreign import stdcall unsafe "windows.h WaitForSingleObject"+  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD++waitForSingleObject :: HANDLE -> DWORD -> IO ()+waitForSingleObject handle timeout =+  Win32.failIf_ bad "WaitForSingleObject" $+    waitForSingleObject_ handle timeout+  where+    bad result   = not (result == 0 || result == wAIT_TIMEOUT)+    wAIT_TIMEOUT = 0x00000102++foreign import stdcall unsafe "windows.h CreateEventW"+  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE++createEvent :: String -> IO HANDLE+createEvent name = do+  Win32.failIfNull "CreateEvent" $+    Win32.withTString name $+      createEvent_ nullPtr False False++foreign import stdcall unsafe "windows.h OpenEventW"+  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++openEvent :: String -> IO HANDLE+openEvent name = do+  Win32.failIfNull "OpenEvent" $+    Win32.withTString name $+      openEvent_ eVENT_MODIFY_STATE False+  where+    eVENT_MODIFY_STATE :: DWORD+    eVENT_MODIFY_STATE = 0x0002++foreign import stdcall unsafe "windows.h SetEvent"+  setEvent_ :: HANDLE -> IO BOOL++setEvent :: HANDLE -> IO ()+setEvent handle =+  Win32.failIfFalse_ "SetEvent" $+    setEvent_ handle++#else++import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die)++possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade _ _ action = action++deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"++#endif
+ Distribution/Client/World.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.World+-- Copyright   :  (c) Peter Robinson 2009+-- License     :  BSD-like+--+-- Maintainer  :  thaldyron@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Interface to the world-file that contains a list of explicitly+-- requested packages. Meant to be imported qualified.+--+-- A world file entry stores the package-name, package-version, and+-- user flags.+-- For example, the entry generated by+-- # cabal install stm-io-hooks --flags="-debug"+-- looks like this:+-- # stm-io-hooks -any --flags="-debug"+-- To rebuild/upgrade the packages in world (e.g. when updating the compiler)+-- use+-- # cabal install world+--+-----------------------------------------------------------------------------+module Distribution.Client.World (+    WorldPkgInfo(..),+    insert,+    delete,+    getContents,+  ) where++import Distribution.Package+         ( Dependency(..) )+import Distribution.PackageDescription+         ( FlagAssignment, FlagName(FlagName) )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( die, info, chattyTry, writeFileAtomic )+import Distribution.Text+         ( Text(..), display, simpleParse )+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ( (<>), (<+>) )+++import Data.Char as Char++import Data.List+         ( unionBy, deleteFirstsBy, nubBy )+import Data.Maybe+         ( isJust, fromJust )+import System.IO.Error+         ( isDoesNotExistError )+import qualified Data.ByteString.Lazy.Char8 as B+import Prelude hiding (getContents)+++data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment+  deriving (Show,Eq)++-- | Adds packages to the world file; creates the file if it doesn't+-- exist yet. Version constraints and flag assignments for a package are+-- updated if already present. IO errors are non-fatal.+insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+insert = modifyWorld $ unionBy equalUDep++-- | Removes packages from the world file.+-- Note: Currently unused as there is no mechanism in Cabal (yet) to+-- handle uninstalls. IO errors are non-fatal.+delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+delete = modifyWorld $ flip (deleteFirstsBy equalUDep)++-- | WorldPkgInfo values are considered equal if they refer to+-- the same package, i.e., we don't care about differing versions or flags.+equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool+equalUDep (WorldPkgInfo (Dependency pkg1 _) _)+          (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2++-- | Modifies the world file by applying an update-function ('unionBy'+-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of+-- packages. IO errors are considered non-fatal.+modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]+                -> [WorldPkgInfo])+                        -- ^ Function that defines how+                        -- the list of user packages are merged with+                        -- existing world packages.+            -> Verbosity+            -> FilePath               -- ^ Location of the world file+            -> [WorldPkgInfo] -- ^ list of user supplied packages+            -> IO ()+modifyWorld _ _         _     []   = return ()+modifyWorld f verbosity world pkgs =+  chattyTry "Error while updating world-file. " $ do+    pkgsOldWorld <- getContents world+    -- Filter out packages that are not in the world file:+    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld+    -- 'Dependency' is not an Ord instance, so we need to check for+    -- equivalence the awkward way:+    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&+            all (`elem` pkgsNewWorld) pkgsOldWorld)+      then do+        info verbosity "Updating world file..."+        writeFileAtomic world $ unlines+            [ (display pkg) | pkg <- pkgsNewWorld]+      else+        info verbosity "World file is already up to date."+++-- | Returns the content of the world file as a list+getContents :: FilePath -> IO [WorldPkgInfo]+getContents world = do+  content <- safelyReadFile world+  let result = map simpleParse (lines $ B.unpack content)+  if all isJust result+    then return $ map fromJust result+    else die "Could not parse world file."+  where+  safelyReadFile :: FilePath -> IO B.ByteString+  safelyReadFile file = B.readFile file `catch` handler+    where+      handler e | isDoesNotExistError e = return B.empty+                | otherwise             = ioError e+++instance Text WorldPkgInfo where+  disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags+    where+      dispFlags [] = Disp.empty+      dispFlags fs = Disp.text "--flags="+                  <> Disp.doubleQuotes (flagAssToDoc fs)+      flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->+                             (if not val then Disp.char '-'+                                         else Disp.empty)+                             Disp.<> Disp.text fname+                             Disp.<+> flagAssDoc)+                           Disp.empty+  parse = do+      dep <- parse+      Parse.skipSpaces+      flagAss <- Parse.option [] parseFlagAssignment+      return $ WorldPkgInfo dep flagAss+    where+      parseFlagAssignment :: Parse.ReadP r FlagAssignment+      parseFlagAssignment = do+          _ <- Parse.string "--flags"+          Parse.skipSpaces+          _ <- Parse.char '='+          Parse.skipSpaces+          inDoubleQuotes $ Parse.many1 flag+        where+          inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a+          inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')++          flag = do+            Parse.skipSpaces+            val <- negative Parse.+++ positive+            name <- ident+            Parse.skipSpaces+            return (FlagName name,val)+          negative = do+            _ <- Parse.char '-'+            return False+          positive = return True++          ident :: Parse.ReadP r String+          ident = do+            -- First character must be a letter/digit to avoid flags+            -- like "+-debug":+            c  <- Parse.satisfy Char.isAlphaNum+            cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'+                                                         || ch == '-')+            return (c:cs)
+ Distribution/Compat/Exception.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-- #hide+module Distribution.Compat.Exception (+  SomeException,+  onException,+  catchIO,+  handleIO,+  catchExit,+  throwIOIO+  ) where++import System.Exit+import qualified Control.Exception as Exception+#if MIN_VERSION_base(4,0,0)+import Control.Exception (SomeException)+#else+import Control.Exception (Exception)+type SomeException = Exception+#endif++onException :: IO a -> IO b -> IO a+#if MIN_VERSION_base(4,0,0)+onException = Exception.onException+#else+onException io what = io `Exception.catch` \e -> do what+                                                    Exception.throw e+#endif++throwIOIO :: Exception.IOException -> IO a+#if MIN_VERSION_base(4,0,0)+throwIOIO = Exception.throwIO+#else+throwIOIO = Exception.throwIO . Exception.IOException+#endif++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#if MIN_VERSION_base(4,0,0)+catchIO = Exception.catch+#else+catchIO = Exception.catchJust Exception.ioErrors+#endif++handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a+handleIO = flip catchIO++catchExit :: IO a -> (ExitCode -> IO a) -> IO a+#if MIN_VERSION_base(4,0,0)+catchExit = Exception.catch+#else+catchExit = Exception.catchJust exitExceptions+    where exitExceptions (Exception.ExitException ee) = Just ee+          exitExceptions _                            = Nothing+#endif
+ Distribution/Compat/FilePerms.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+-- #hide+module Distribution.Compat.FilePerms (+  setFileOrdinary,+  setFileExecutable,+  ) where++#ifndef mingw32_HOST_OS+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+import Foreign.C+         ( withCString )+#if MIN_VERSION_base(4,0,0)+import Foreign.C+         ( throwErrnoPathIfMinus1_ )+#else+import Foreign.C+         ( throwErrnoIfMinus1_ )+#endif+#endif /* mingw32_HOST_OS */++setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+  withCString name $ \s -> do+#if __GLASGOW_HASKELL__ >= 608+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+    throwErrnoIfMinus1_                   name (c_chmod s m)+#endif+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+#endif
+ Main.hs view
@@ -0,0 +1,403 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Entry point to the default cabal-install front-end.+-----------------------------------------------------------------------------++module Main (main) where++import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand, globalRepos+         , ConfigFlags(..)+         , ConfigExFlags(..), configureExCommand+         , InstallFlags(..), defaultInstallFlags+         , installCommand, upgradeCommand+         , FetchFlags(..), fetchCommand+         , checkCommand+         , updateCommand+         , ListFlags(..), listCommand+         , InfoFlags(..), infoCommand+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , InitFlags, initCommand+         , reportCommand+         , unpackCommand, UnpackFlags(..) )+import Distribution.Simple.Setup+         ( BuildFlags(..), buildCommand+         , HaddockFlags(..), haddockCommand+         , HscolourFlags(..), hscolourCommand+         , CopyFlags(..), copyCommand+         , RegisterFlags(..), registerCommand+         , CleanFlags(..), cleanCommand+         , SDistFlags(..), sdistCommand+         , TestFlags(..), testCommand+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )++import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Config+         ( SavedConfig(..), loadConfig, defaultConfigFile )+import Distribution.Client.Targets+         ( readUserTargets )++import Distribution.Client.List             (list, info)+import Distribution.Client.Install          (install, upgrade)+import Distribution.Client.Configure        (configure)+import Distribution.Client.Update           (update)+import Distribution.Client.Fetch            (fetch)+import Distribution.Client.Check as Check   (check)+--import Distribution.Client.Clean            (clean)+import Distribution.Client.Upload as Upload (upload, check, report)+import Distribution.Client.SrcDist          (sdist)+import Distribution.Client.Unpack           (unpack)+import Distribution.Client.Init             (initCabal)+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade++import Distribution.Simple.Compiler+         ( Compiler, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration, defaultProgramConfiguration )+import Distribution.Simple.Command+import Distribution.Simple.Configure (configCompilerAux)+import Distribution.Simple.Utils+         ( cabalVersion, die, topHandler, intercalate )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+       ( Verbosity, normal, intToVerbosity, lessVerbose )+import qualified Paths_cabal_install_bundle (version)++import System.Environment       (getArgs, getProgName)+import System.Exit              (exitFailure)+import System.FilePath          (splitExtension, takeExtension)+import System.Directory         (doesFileExist)+import Data.List                (intersperse)+import Data.Maybe               (fromMaybe)+import Data.Monoid              (Monoid(..))+import Control.Monad            (unless)++-- | Entry point+--+main :: IO ()+main = getArgs >>= mainWorker++mainWorker :: [String] -> IO ()+mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args+mainWorker args = topHandler $+  case commandsRun globalCommand commands args of+    CommandHelp   help                 -> printGlobalHelp help+    CommandList   opts                 -> printOptionsList opts+    CommandErrors errs                 -> printErrors errs+    CommandReadyToGo (globalflags, commandParse)  ->+      case commandParse of+        _ | fromFlag (globalVersion globalflags)        -> printVersion+          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        CommandHelp     help           -> printCommandHelp help+        CommandList     opts           -> printOptionsList opts+        CommandErrors   errs           -> printErrors errs+        CommandReadyToGo action        -> action globalflags++  where+    printCommandHelp help = do+      pname <- getProgName+      putStr (help pname)+    printGlobalHelp help = do+      pname <- getProgName+      configFile <- defaultConfigFile+      putStr (help pname)+      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"+            ++ "  " ++ configFile ++ "\n"+    printOptionsList = putStr . unlines+    printErrors errs = die $ concat (intersperse "\n" errs)+    printNumericVersion = putStrLn $ display Paths_cabal_install_bundle.version+    printVersion        = putStrLn $ "cabal-install version "+                                  ++ display Paths_cabal_install_bundle.version+                                  ++ "\nusing version "+                                  ++ display cabalVersion+                                  ++ " of the Cabal library "++    commands =+      [installCommand         `commandAddAction` installAction+      ,updateCommand          `commandAddAction` updateAction+      ,listCommand            `commandAddAction` listAction+      ,infoCommand            `commandAddAction` infoAction+      ,fetchCommand           `commandAddAction` fetchAction+      ,unpackCommand          `commandAddAction` unpackAction+      ,checkCommand           `commandAddAction` checkAction+      ,sdistCommand           `commandAddAction` sdistAction+      ,uploadCommand          `commandAddAction` uploadAction+      ,reportCommand          `commandAddAction` reportAction+      ,initCommand            `commandAddAction` initAction+      ,configureExCommand     `commandAddAction` configureAction+      ,wrapperAction (buildCommand defaultProgramConfiguration)+                     buildVerbosity    buildDistPref+      ,wrapperAction copyCommand+                     copyVerbosity     copyDistPref+      ,wrapperAction haddockCommand+                     haddockVerbosity  haddockDistPref+      ,wrapperAction cleanCommand+                     cleanVerbosity    cleanDistPref+      ,wrapperAction hscolourCommand+                     hscolourVerbosity hscolourDistPref+      ,wrapperAction registerCommand+                     regVerbosity      regDistPref+      ,wrapperAction testCommand+                     testVerbosity     testDistPref+      ,upgradeCommand         `commandAddAction` upgradeAction+      ]++wrapperAction :: Monoid flags+              => CommandUI flags+              -> (flags -> Flag Verbosity)+              -> (flags -> Flag String)+              -> Command (GlobalFlags -> IO ())+wrapperAction command verbosityFlag distPrefFlag =+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do+    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)+        setupScriptOptions = defaultSetupScriptOptions {+          useDistPref = fromFlagOrDefault+                          (useDistPref defaultSetupScriptOptions)+                          (distPrefFlag flags)+        }+    setupWrapper verbosity setupScriptOptions Nothing+                 command (const flags) extraArgs++configureAction :: (ConfigFlags, ConfigExFlags)+                -> [String] -> GlobalFlags -> IO ()+configureAction (configFlags, configExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags'+  configure verbosity+            (configPackageDB' configFlags') (globalRepos globalFlags')+            comp conf configFlags' configExFlags' extraArgs++installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+installAction (configFlags, _, installFlags) _ _globalFlags+  | fromFlagOrDefault False (installOnly installFlags)+  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    in setupWrapper verbosity defaultSetupScriptOptions Nothing+         installCommand (const mempty) []++installAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = defaultInstallFlags          `mappend`+                       savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags'+  install verbosity+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf globalFlags' configFlags' configExFlags' installFlags'+          targets++listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction listFlags extraArgs globalFlags = do+  let verbosity = fromFlag (listVerbosity listFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags+  list verbosity+       (configPackageDB' configFlags)+       (globalRepos globalFlags')+       comp+       conf+       listFlags+       extraArgs++infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()+infoAction infoFlags extraArgs globalFlags = do+  let verbosity = fromFlag (infoVerbosity infoFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags+  info verbosity+       (configPackageDB' configFlags)+       (globalRepos globalFlags')+       comp+       conf+       globalFlags'+       infoFlags+       targets++updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+updateAction verbosityFlag extraArgs globalFlags = do+  unless (null extraArgs) $ do+    die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs+  let verbosity = fromFlag verbosityFlag+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  update verbosity (globalRepos globalFlags')++upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+upgradeAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = defaultInstallFlags          `mappend`+                       savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags'+  upgrade verbosity+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf globalFlags' configFlags' configExFlags' installFlags'+          targets++fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()+fetchAction fetchFlags extraArgs globalFlags = do+  let verbosity = fromFlag (fetchVerbosity fetchFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags+  fetch verbosity+        (configPackageDB' configFlags) (globalRepos globalFlags')+        comp conf globalFlags' fetchFlags+        targets++uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()+uploadAction uploadFlags extraArgs globalFlags = do+  let verbosity = fromFlag (uploadVerbosity uploadFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+      tarfiles     = extraArgs+  checkTarFiles extraArgs+  if fromFlag (uploadCheck uploadFlags')+    then Upload.check  verbosity tarfiles+    else upload verbosity+                (globalRepos globalFlags')+                (flagToMaybe $ uploadUsername uploadFlags')+                (flagToMaybe $ uploadPassword uploadFlags')+                tarfiles+  where+    checkTarFiles tarfiles+      | null tarfiles+      = die "the 'upload' command expects one or more .tar.gz packages."+      | not (null otherFiles)+      = die $ "the 'upload' command expects only .tar.gz packages: "+           ++ intercalate ", " otherFiles+      | otherwise = sequence_+                      [ do exists <- doesFileExist tarfile+                           unless exists $ die $ "file not found: " ++ tarfile+                      | tarfile <- tarfiles ]++      where otherFiles = filter (not . isTarGzFile) tarfiles+            isTarGzFile file = case splitExtension file of+              (file', ".gz") -> takeExtension file' == ".tar"+              _              -> False++checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+checkAction verbosityFlag extraArgs _globalFlags = do+  unless (null extraArgs) $ do+    die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs+  allOk <- Check.check (fromFlag verbosityFlag)+  unless allOk exitFailure+++sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()+sdistAction sflags extraArgs _globalFlags = do+  unless (null extraArgs) $ do+    die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs+  sdist sflags++reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()+reportAction reportFlags extraArgs globalFlags = do+  unless (null extraArgs) $ do+    die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs++  let verbosity = fromFlag (reportVerbosity reportFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+      reportFlags' = savedReportFlags config `mappend` reportFlags++  Upload.report verbosity (globalRepos globalFlags')+    (flagToMaybe $ reportUsername reportFlags')+    (flagToMaybe $ reportPassword reportFlags')++unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()+unpackAction unpackFlags extraArgs globalFlags = do+  let verbosity = fromFlag (unpackVerbosity unpackFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  unpack verbosity+         (globalRepos (savedGlobalFlags config))+         globalFlags'+         unpackFlags+         targets++initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()+initAction flags _extraArgs _globalFlags = do+  initCabal flags++-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+--+win32SelfUpgradeAction :: [String] -> IO ()+win32SelfUpgradeAction (pid:path:rest) =+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path+  where+    verbosity = case rest of+      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']+         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))+      _  ->           Verbosity.normal+win32SelfUpgradeAction _ = return ()++--+-- Utils (transitionary)+--++-- | Currently the user interface specifies the package dbs to use with just a+-- single valued option, a 'PackageDB'. However internally we represent the+-- stack of 'PackageDB's explictly as a list. This function converts encodes+-- the package db stack implicit in a single packagedb.+--+-- TODO: sort this out, make it consistent with the command line UI+implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack+implicitPackageDbStack userInstall packageDbFlag+  | userInstall = GlobalPackageDB : UserPackageDB : extra+  | otherwise   = GlobalPackageDB : extra+  where+    extra = case packageDbFlag of+      Just (SpecificPackageDB db) -> [SpecificPackageDB db]+      _                           -> []++configPackageDB' :: ConfigFlags -> PackageDBStack+configPackageDB' cfg =+  implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))+  where+    userInstall = fromFlagOrDefault True (configUserInstall cfg)++configCompilerAux' :: ConfigFlags+                   -> IO (Compiler, ProgramConfiguration)+configCompilerAux' configFlags =+  configCompilerAux configFlags+    --FIXME: make configCompilerAux use a sensible verbosity+    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
+ Network.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/network/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The "Network" interface is a \"higher-level\" interface to+-- networking facilities, and it is recommended unless you need the+-- lower-level interface in "Network.Socket".+--+-----------------------------------------------------------------------------++#include "HsNetworkConfig.h"++#ifdef HAVE_GETADDRINFO+-- Use IPv6-capable function definitions if the OS supports it.+#define IPV6_SOCKET_SUPPORT 1+#endif++module Network+    (+    -- * Basic data types+      Socket+    , PortID(..)+    , HostName+    , PortNumber++    -- * Initialisation+    , withSocketsDo+    +    -- * Server-side connections+    , listenOn+    , accept+    , sClose++    -- * Client-side connections+    , connectTo++    -- * Simple sending and receiving+    {-$sendrecv-}+    , sendTo+    , recvFrom++    -- * Miscellaneous+    , socketPort++    -- * Networking Issues+    -- ** Buffering+    {-$buffering-}++    -- ** Improving I\/O Performance over sockets+    {-$performance-}++    -- ** @SIGPIPE@+    {-$sigpipe-}+    ) where++import Control.Monad (liftM)+import Data.Maybe (fromJust)+import Network.BSD+import Network.Socket hiding (accept, socketPort, recvFrom, sendTo, PortNumber)+import qualified Network.Socket as Socket (accept)+import System.IO+import Prelude+import qualified Control.Exception as Exception++-- ---------------------------------------------------------------------------+-- High Level ``Setup'' functions++-- If the @PortID@ specifies a unix family socket and the @Hostname@+-- differs from that returned by @getHostname@ then an error is+-- raised. Alternatively an empty string may be given to @connectTo@+-- signalling that the current hostname applies.++data PortID = +          Service String                -- Service Name eg "ftp"+        | PortNumber PortNumber         -- User defined Port Number+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+        | UnixSocket String             -- Unix family socket in file system+#endif++-- | Calling 'connectTo' creates a client side socket which is+-- connected to the given host and port.  The Protocol and socket type is+-- derived from the given port identifier.  If a port number is given+-- then the result is always an internet family 'Stream' socket. ++connectTo :: HostName           -- Hostname+          -> PortID             -- Port Identifier+          -> IO Handle          -- Connected Socket++#if defined(IPV6_SOCKET_SUPPORT)+-- IPv6 and IPv4.++connectTo hostname (Service serv) = connect' hostname serv++connectTo hostname (PortNumber port) = connect' hostname (show port)+#else+-- IPv4 only.++connectTo hostname (Service serv) = do+    proto <- getProtocolNumber "tcp"+    bracketOnError+        (socket AF_INET Stream proto)+        (sClose)  -- only done if there's an error+        (\sock -> do+          port  <- getServicePortNumber serv+          he    <- getHostByName hostname+          connect sock (SockAddrInet port (hostAddress he))+          socketToHandle sock ReadWriteMode+        )++connectTo hostname (PortNumber port) = do+    proto <- getProtocolNumber "tcp"+    bracketOnError+        (socket AF_INET Stream proto)+        (sClose)  -- only done if there's an error+        (\sock -> do+          he <- getHostByName hostname+          connect sock (SockAddrInet port (hostAddress he))+          socketToHandle sock ReadWriteMode+        )+#endif++#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+connectTo _ (UnixSocket path) = do+    bracketOnError+        (socket AF_UNIX Stream 0)+        (sClose)+        (\sock -> do+          connect sock (SockAddrUnix path)+          socketToHandle sock ReadWriteMode+        )+#endif++#if defined(IPV6_SOCKET_SUPPORT)+connect' :: HostName -> ServiceName -> IO Handle++connect' host serv = do+    proto <- getProtocolNumber "tcp"+    let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+                             , addrProtocol = proto+                             , addrSocketType = Stream }+    addrs <- getAddrInfo (Just hints) (Just host) (Just serv)+    firstSuccessful $ map tryToConnect addrs+  where+  tryToConnect addr =+    bracketOnError+        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+        (sClose)  -- only done if there's an error+        (\sock -> do+          connect sock (addrAddress addr)+          socketToHandle sock ReadWriteMode+        )+#endif++-- | Creates the server side socket which has been bound to the+-- specified port.+--+-- NOTE: To avoid the \"Address already in use\"+-- problems popped up several times on the GHC-Users mailing list we+-- set the 'ReuseAddr' socket option on the listening socket.  If you+-- don't want this behaviour, please use the lower level+-- 'Network.Socket.listen' instead.+--+-- If available, the 'IPv6Only' socket option is set to 0+-- so that both IPv4 and IPv6 can be accepted with this socket.++listenOn :: PortID      -- ^ Port Identifier+         -> IO Socket   -- ^ Connected Socket++#if defined(IPV6_SOCKET_SUPPORT)+-- IPv6 and IPv4.++listenOn (Service serv) = listen' serv++listenOn (PortNumber port) = listen' (show port)+#else+-- IPv4 only.++listenOn (Service serv) = do+    proto <- getProtocolNumber "tcp"+    bracketOnError+        (socket AF_INET Stream proto)+        (sClose)+        (\sock -> do+            port    <- getServicePortNumber serv+            setSocketOption sock ReuseAddr 1+            bindSocket sock (SockAddrInet port iNADDR_ANY)+            listen sock maxListenQueue+            return sock+        )++listenOn (PortNumber port) = do+    proto <- getProtocolNumber "tcp"+    bracketOnError+        (socket AF_INET Stream proto)+        (sClose)+        (\sock -> do+            setSocketOption sock ReuseAddr 1+            bindSocket sock (SockAddrInet port iNADDR_ANY)+            listen sock maxListenQueue+            return sock+        )+#endif++#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+listenOn (UnixSocket path) =+    bracketOnError+        (socket AF_UNIX Stream 0)+        (sClose)+        (\sock -> do+            setSocketOption sock ReuseAddr 1+            bindSocket sock (SockAddrUnix path)+            listen sock maxListenQueue+            return sock+        )+#endif++#if defined(IPV6_SOCKET_SUPPORT)+listen' :: ServiceName -> IO Socket++listen' serv = do+    proto <- getProtocolNumber "tcp"+    -- We should probably specify addrFamily = AF_INET6 and the filter+    -- code below should be removed. AI_ADDRCONFIG is probably not+    -- necessary. But this code is well-tested. So, let's keep it.+    let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE]+                             , addrSocketType = Stream+                             , addrProtocol = proto }+    addrs <- getAddrInfo (Just hints) Nothing (Just serv)+    -- Choose an IPv6 socket if exists.  This ensures the socket can+    -- handle both IPv4 and IPv6 if v6only is false.+    let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs+        addr = if null addrs' then head addrs else head addrs'+    bracketOnError+        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+        (sClose)+        (\sock -> do+            setSocketOption sock ReuseAddr 1+            bindSocket sock (addrAddress addr)+            listen sock maxListenQueue+            return sock+        )+#endif++-- -----------------------------------------------------------------------------+-- accept++-- | Accept a connection on a socket created by 'listenOn'.  Normal+-- I\/O operations (see "System.IO") can be used on the 'Handle'+-- returned to communicate with the client.+-- Notice that although you can pass any Socket to Network.accept,+-- only sockets of either AF_UNIX, AF_INET, or AF_INET6 will work+-- (this shouldn't be a problem, though). When using AF_UNIX, HostName+-- will be set to the path of the socket and PortNumber to -1.+--+accept :: Socket                -- ^ Listening Socket+       -> IO (Handle,+              HostName,+              PortNumber)       -- ^ Triple of: read\/write 'Handle' for +                                -- communicating with the client,+                                -- the 'HostName' of the peer socket, and+                                -- the 'PortNumber' of the remote connection.+accept sock@(MkSocket _ AF_INET _ _ _) = do+ ~(sock', (SockAddrInet port haddr)) <- Socket.accept sock+ peer <- catchIO+          (do   +             (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr+             return peer+          )+          (\_e -> inet_ntoa haddr)+                -- if getHostByName fails, we fall back to the IP address+ handle <- socketToHandle sock' ReadWriteMode+ return (handle, peer, port)+#if defined(IPV6_SOCKET_SUPPORT)+accept sock@(MkSocket _ AF_INET6 _ _ _) = do+ (sock', addr) <- Socket.accept sock+ peer <- catchIO ((fromJust . fst) `liftM` getNameInfo [] True False addr) $+         \_ -> case addr of+                 SockAddrInet  _   a   -> inet_ntoa a+                 SockAddrInet6 _ _ a _ -> return (show a)+# if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+                 SockAddrUnix      a   -> return a+# endif+ handle <- socketToHandle sock' ReadWriteMode+ let port = case addr of+              SockAddrInet  p _     -> p+              SockAddrInet6 p _ _ _ -> p+              _                     -> -1+ return (handle, peer, port)+#endif+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+accept sock@(MkSocket _ AF_UNIX _ _ _) = do+ ~(sock', (SockAddrUnix path)) <- Socket.accept sock+ handle <- socketToHandle sock' ReadWriteMode+ return (handle, path, -1)+#endif+accept (MkSocket _ family _ _ _) =+  error $ "Sorry, address family " ++ (show family) ++ " is not supported!"++-- -----------------------------------------------------------------------------+-- sendTo/recvFrom++{-$sendrecv+Send and receive data from\/to the given host and port number.  These+should normally only be used where the socket will not be required for+further calls. Also, note that due to the use of 'hGetContents' in 'recvFrom'+the socket will remain open (i.e. not available) even if the function already+returned. Their use is strongly discouraged except for small test-applications+or invocations from the command line.+-}++sendTo :: HostName      -- Hostname+       -> PortID        -- Port Number+       -> String        -- Message to send+       -> IO ()+sendTo h p msg = do+  s <- connectTo h p+  hPutStr s msg+  hClose s++recvFrom :: HostName    -- Hostname+         -> PortID      -- Port Number+         -> IO String   -- Received Data++#if defined(IPV6_SOCKET_SUPPORT)+recvFrom host port = do+    proto <- getProtocolNumber "tcp"+    let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+                             , addrProtocol = proto+                             , addrSocketType = Stream }+    allowed <- map addrAddress `liftM` getAddrInfo (Just hints) (Just host)+                                                   Nothing+    s <- listenOn port+    let waiting = do+        (s', addr) <- Socket.accept s+        if not (addr `oneOf` allowed)+         then sClose s' >> waiting+         else socketToHandle s' ReadMode >>= hGetContents+    waiting+  where+    a@(SockAddrInet _ ha) `oneOf` ((SockAddrInet _ hb):bs)+        | ha == hb = True+        | otherwise = a `oneOf` bs+    a@(SockAddrInet6 _ _ ha _) `oneOf` ((SockAddrInet6 _ _ hb _):bs)+        | ha == hb = True+        | otherwise = a `oneOf` bs+    _ `oneOf` _ = False+#else+recvFrom host port = do+ ip  <- getHostByName host+ let ipHs = hostAddresses ip+ s   <- listenOn port+ let +  waiting = do+     ~(s', SockAddrInet _ haddr)  <-  Socket.accept s+     he <- getHostByAddr AF_INET haddr+     if not (any (`elem` ipHs) (hostAddresses he))+      then do+         sClose s'+         waiting+      else do+        h <- socketToHandle s' ReadMode+        msg <- hGetContents h+        return msg++ message <- waiting+ return message+#endif++-- ---------------------------------------------------------------------------+-- Access function returning the port type/id of socket.++-- | Returns the 'PortID' associated with a given socket.+socketPort :: Socket -> IO PortID+socketPort s = do+    sockaddr <- getSocketName s+    return (portID sockaddr)+  where+   portID sa =+    case sa of+     SockAddrInet port _      -> PortNumber port+#if defined(IPV6_SOCKET_SUPPORT)+     SockAddrInet6 port _ _ _ -> PortNumber port+#endif+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+     SockAddrUnix path        -> UnixSocket path+#endif++-- ---------------------------------------------------------------------------+-- Utils++-- Like bracket, but only performs the final action if there was an +-- exception raised by the middle bit.+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+#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 606+bracketOnError before after thing =+  Exception.block (do+    a <- before+    r <- Exception.catch+           (Exception.unblock (thing a))+           (\e -> do { after a; Exception.throw e })+    return r+ )+#else+bracketOnError = Exception.bracketOnError+#endif++-----------------------------------------------------------------------------+-- Extra documentation++{-$buffering++The 'Handle' returned by 'connectTo' and 'accept' is block-buffered by+default.  For an interactive application you may want to set the+buffering mode on the 'Handle' to+'LineBuffering' or 'NoBuffering', like so:++> h <- connectTo host port+> hSetBuffering h LineBuffering+-}++{-$performance++For really fast I\/O, it might be worth looking at the 'hGetBuf' and+'hPutBuf' family of functions in "System.IO".+-}++{-$sigpipe++On Unix, when writing to a socket and the reading end is+closed by the remote client, the program is normally sent a+@SIGPIPE@ signal by the operating system.  The+default behaviour when a @SIGPIPE@ is received is+to terminate the program silently, which can be somewhat confusing+if you haven't encountered this before.  The solution is to+specify that @SIGPIPE@ is to be ignored, using+the POSIX library:++>  import Posix+>  main = do installHandler sigPIPE Ignore Nothing; ...+-}++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#if MIN_VERSION_base(4,0,0)+catchIO = Exception.catch+#else+catchIO = Exception.catchJust Exception.ioErrors+#endif++-- Returns the first action from a list which does not throw an exception.+-- If all the actions throw exceptions (and the list of actions is not empty),+-- the last exception is thrown.+firstSuccessful :: [IO a] -> IO a+firstSuccessful [] = error "firstSuccessful: empty list"+firstSuccessful (p:ps) = catchIO p $ \e ->+    case ps of+        [] -> Exception.throw e+        _  -> firstSuccessful ps
+ Network/BSD.hsc view
@@ -0,0 +1,587 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.BSD+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/network/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- The "Network.BSD" module defines Haskell bindings to network+-- programming functionality provided by BSD Unix derivatives.+--+-----------------------------------------------------------------------------++#include "HsNet.h"++-- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs.+##include "Typeable.h"++module Network.BSD+    (+    -- * Host names+      HostName+    , getHostName++    , HostEntry(..)+    , getHostByName+    , getHostByAddr+    , hostAddress++#if defined(HAVE_GETHOSTENT) && !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+    , getHostEntries++    -- ** Low level functionality+    , setHostEntry+    , getHostEntry+    , endHostEntry+#endif++    -- * Service names+    , ServiceEntry(..)+    , ServiceName+    , getServiceByName+    , getServiceByPort+    , getServicePortNumber++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+    , getServiceEntries++    -- ** Low level functionality+    , getServiceEntry+    , setServiceEntry+    , endServiceEntry+#endif++    -- * Protocol names+    , ProtocolName+    , ProtocolNumber+    , ProtocolEntry(..)+    , getProtocolByName+    , getProtocolByNumber+    , getProtocolNumber+    , defaultProtocol++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+    , getProtocolEntries+    -- ** Low level functionality+    , setProtocolEntry+    , getProtocolEntry+    , endProtocolEntry+#endif++    -- * Port numbers+    , PortNumber++    -- * Network names+    , NetworkName+    , NetworkAddr+    , NetworkEntry(..)++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+    , getNetworkByName+    , getNetworkByAddr+    , getNetworkEntries+    -- ** Low level functionality+    , setNetworkEntry+    , getNetworkEntry+    , endNetworkEntry+#endif+    ) where++#ifdef __HUGS__+import Hugs.Prelude (IOException(..), IOErrorType(..))+#endif+import Network.Socket++import Control.Concurrent (MVar, newMVar, withMVar)+import Control.Exception (catch)+import Foreign.C.String (CString, peekCString, withCString)+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+import Foreign.C.Types ( CShort )+#endif+#if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) )+#else+import Foreign.C.Types ( CInt, CULong, CSize )+#endif+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (allocaArray0, peekArray0)+import Foreign.Marshal.Utils (with, fromBool)+import Data.Typeable+import Prelude hiding (catch)+import System.IO.Error (ioeSetErrorString, mkIOError)+import System.IO.Unsafe (unsafePerformIO)++#ifdef __GLASGOW_HASKELL__+# if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Exception+# else+import GHC.IOBase+# endif+#endif++import Control.Monad (liftM)++-- ---------------------------------------------------------------------------+-- Basic Types++type ProtocolName = String++-- ---------------------------------------------------------------------------+-- Service Database Access++-- Calling getServiceByName for a given service and protocol returns+-- the systems service entry.  This should be used to find the port+-- numbers for standard protocols such as SMTP and FTP.  The remaining+-- three functions should be used for browsing the service database+-- sequentially.++-- Calling setServiceEntry with True indicates that the service+-- database should be left open between calls to getServiceEntry.  To+-- close the database a call to endServiceEntry is required.  This+-- database file is usually stored in the file /etc/services.++data ServiceEntry  = +  ServiceEntry  {+     serviceName     :: ServiceName,    -- Official Name+     serviceAliases  :: [ServiceName],  -- aliases+     servicePort     :: PortNumber,     -- Port Number  ( network byte order )+     serviceProtocol :: ProtocolName    -- Protocol+  } deriving (Show, Typeable)++instance Storable ServiceEntry where+   sizeOf    _ = #const sizeof(struct servent)+   alignment _ = alignment (undefined :: CInt) -- ???++   peek p = do+        s_name    <- (#peek struct servent, s_name) p >>= peekCString+        s_aliases <- (#peek struct servent, s_aliases) p+                           >>= peekArray0 nullPtr+                           >>= mapM peekCString+        s_port    <- (#peek struct servent, s_port) p+        s_proto   <- (#peek struct servent, s_proto) p >>= peekCString+        return (ServiceEntry {+                        serviceName     = s_name,+                        serviceAliases  = s_aliases,+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+                        servicePort     = PortNum (fromIntegral (s_port :: CShort)),+#else+                           -- s_port is already in network byte order, but it+                           -- might be the wrong size.+                        servicePort     = PortNum (fromIntegral (s_port :: CInt)),+#endif+                        serviceProtocol = s_proto+                })++   poke _p = error "Storable.poke(BSD.ServiceEntry) not implemented"+++-- | Get service by name.+getServiceByName :: ServiceName         -- Service Name+                 -> ProtocolName        -- Protocol Name+                 -> IO ServiceEntry     -- Service Entry+getServiceByName name proto = withLock $ do+ withCString name  $ \ cstr_name  -> do+ withCString proto $ \ cstr_proto -> do+ throwNoSuchThingIfNull "getServiceByName" "no such service entry"+   $ (trySysCall (c_getservbyname cstr_name cstr_proto))+ >>= peek++foreign import CALLCONV unsafe "getservbyname" +  c_getservbyname :: CString -> CString -> IO (Ptr ServiceEntry)++-- | Get the service given a 'PortNumber' and 'ProtocolName'.+getServiceByPort :: PortNumber -> ProtocolName -> IO ServiceEntry+getServiceByPort (PortNum port) proto = withLock $ do+ withCString proto $ \ cstr_proto -> do+ throwNoSuchThingIfNull "getServiceByPort" "no such service entry"+   $ (trySysCall (c_getservbyport (fromIntegral port) cstr_proto))+ >>= peek++foreign import CALLCONV unsafe "getservbyport" +  c_getservbyport :: CInt -> CString -> IO (Ptr ServiceEntry)++-- | Get the 'PortNumber' corresponding to the 'ServiceName'.+getServicePortNumber :: ServiceName -> IO PortNumber+getServicePortNumber name = do+    (ServiceEntry _ _ port _) <- getServiceByName name "tcp"+    return port++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+getServiceEntry :: IO ServiceEntry+getServiceEntry = withLock $ do+ throwNoSuchThingIfNull "getServiceEntry" "no such service entry"+   $ trySysCall c_getservent+ >>= peek++foreign import ccall unsafe "getservent" c_getservent :: IO (Ptr ServiceEntry)++setServiceEntry :: Bool -> IO ()+setServiceEntry flg = withLock $ trySysCall $ c_setservent (fromBool flg)++foreign import ccall unsafe  "setservent" c_setservent :: CInt -> IO ()++endServiceEntry :: IO ()+endServiceEntry = withLock $ trySysCall $ c_endservent++foreign import ccall unsafe  "endservent" c_endservent :: IO ()++getServiceEntries :: Bool -> IO [ServiceEntry]+getServiceEntries stayOpen = do+  setServiceEntry stayOpen+  getEntries (getServiceEntry) (endServiceEntry)+#endif++-- ---------------------------------------------------------------------------+-- Protocol Entries++-- The following relate directly to the corresponding UNIX C+-- calls for returning the protocol entries. The protocol entry is+-- represented by the Haskell type ProtocolEntry.++-- As for setServiceEntry above, calling setProtocolEntry.+-- determines whether or not the protocol database file, usually+-- @/etc/protocols@, is to be kept open between calls of+-- getProtocolEntry. Similarly, ++data ProtocolEntry = +  ProtocolEntry  {+     protoName    :: ProtocolName,      -- Official Name+     protoAliases :: [ProtocolName],    -- aliases+     protoNumber  :: ProtocolNumber     -- Protocol Number+  } deriving (Read, Show, Typeable)++instance Storable ProtocolEntry where+   sizeOf    _ = #const sizeof(struct protoent)+   alignment _ = alignment (undefined :: CInt) -- ???++   peek p = do+        p_name    <- (#peek struct protoent, p_name) p >>= peekCString+        p_aliases <- (#peek struct protoent, p_aliases) p+                           >>= peekArray0 nullPtr+                           >>= mapM peekCString+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+         -- With WinSock, the protocol number is only a short;+         -- hoist it in as such, but represent it on the Haskell side+         -- as a CInt.+        p_proto_short  <- (#peek struct protoent, p_proto) p +        let p_proto = fromIntegral (p_proto_short :: CShort)+#else+        p_proto        <- (#peek struct protoent, p_proto) p +#endif+        return (ProtocolEntry { +                        protoName    = p_name,+                        protoAliases = p_aliases,+                        protoNumber  = p_proto+                })++   poke _p = error "Storable.poke(BSD.ProtocolEntry) not implemented"++getProtocolByName :: ProtocolName -> IO ProtocolEntry+getProtocolByName name = withLock $ do+ withCString name $ \ name_cstr -> do+ throwNoSuchThingIfNull "getProtocolByName" ("no such protocol name: " ++ name)+   $ (trySysCall.c_getprotobyname) name_cstr+ >>= peek++foreign import  CALLCONV unsafe  "getprotobyname" +   c_getprotobyname :: CString -> IO (Ptr ProtocolEntry)+++getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry+getProtocolByNumber num = withLock $ do+ throwNoSuchThingIfNull "getProtocolByNumber" ("no such protocol number: " ++ show num)+   $ (trySysCall.c_getprotobynumber) (fromIntegral num)+ >>= peek++foreign import CALLCONV unsafe  "getprotobynumber"+   c_getprotobynumber :: CInt -> IO (Ptr ProtocolEntry)+++getProtocolNumber :: ProtocolName -> IO ProtocolNumber+getProtocolNumber proto = do+ (ProtocolEntry _ _ num) <- getProtocolByName proto+ return num++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+getProtocolEntry :: IO ProtocolEntry    -- Next Protocol Entry from DB+getProtocolEntry = withLock $ do+ ent <- throwNoSuchThingIfNull "getProtocolEntry" "no such protocol entry"+                $ trySysCall c_getprotoent+ peek ent++foreign import ccall unsafe  "getprotoent" c_getprotoent :: IO (Ptr ProtocolEntry)++setProtocolEntry :: Bool -> IO ()       -- Keep DB Open ?+setProtocolEntry flg = withLock $ trySysCall $ c_setprotoent (fromBool flg)++foreign import ccall unsafe "setprotoent" c_setprotoent :: CInt -> IO ()++endProtocolEntry :: IO ()+endProtocolEntry = withLock $ trySysCall $ c_endprotoent++foreign import ccall unsafe "endprotoent" c_endprotoent :: IO ()++getProtocolEntries :: Bool -> IO [ProtocolEntry]+getProtocolEntries stayOpen = withLock $ do+  setProtocolEntry stayOpen+  getEntries (getProtocolEntry) (endProtocolEntry)+#endif++-- ---------------------------------------------------------------------------+-- Host lookups++data HostEntry = +  HostEntry  {+     hostName      :: HostName,         -- Official Name+     hostAliases   :: [HostName],       -- aliases+     hostFamily    :: Family,           -- Host Type (currently AF_INET)+     hostAddresses :: [HostAddress]     -- Set of Network Addresses  (in network byte order)+  } deriving (Read, Show, Typeable)++instance Storable HostEntry where+   sizeOf    _ = #const sizeof(struct hostent)+   alignment _ = alignment (undefined :: CInt) -- ???++   peek p = do+        h_name       <- (#peek struct hostent, h_name) p >>= peekCString+        h_aliases    <- (#peek struct hostent, h_aliases) p+                                >>= peekArray0 nullPtr+                                >>= mapM peekCString+        h_addrtype   <- (#peek struct hostent, h_addrtype) p+        -- h_length       <- (#peek struct hostent, h_length) p+        h_addr_list  <- (#peek struct hostent, h_addr_list) p+                                >>= peekArray0 nullPtr+                                >>= mapM peek+        return (HostEntry {+                        hostName       = h_name,+                        hostAliases    = h_aliases,+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+                        hostFamily     = unpackFamily (fromIntegral (h_addrtype :: CShort)),+#else+                        hostFamily     = unpackFamily h_addrtype,+#endif+                        hostAddresses  = h_addr_list+                })++   poke _p = error "Storable.poke(BSD.ServiceEntry) not implemented"+++-- convenience function:+hostAddress :: HostEntry -> HostAddress+hostAddress (HostEntry nm _ _ ls) =+ case ls of+   []    -> error ("BSD.hostAddress: empty network address list for " ++ nm)+   (x:_) -> x++-- getHostByName must use the same lock as the *hostent functions+-- may cause problems if called concurrently.++-- | Resolve a 'HostName' to IPv4 address.+getHostByName :: HostName -> IO HostEntry+getHostByName name = withLock $ do+  withCString name $ \ name_cstr -> do+   ent <- throwNoSuchThingIfNull "getHostByName" "no such host entry"+                $ trySysCall $ c_gethostbyname name_cstr+   peek ent++foreign import CALLCONV safe "gethostbyname" +   c_gethostbyname :: CString -> IO (Ptr HostEntry)+++-- The locking of gethostbyaddr is similar to gethostbyname.+-- | Get a 'HostEntry' corresponding to the given address and family.+-- Note that only IPv4 is currently supported.+getHostByAddr :: Family -> HostAddress -> IO HostEntry+getHostByAddr family addr = do+ with addr $ \ ptr_addr -> withLock $ do+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"+   $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family)+ >>= peek++foreign import CALLCONV safe "gethostbyaddr"+   c_gethostbyaddr :: Ptr HostAddress -> CInt -> CInt -> IO (Ptr HostEntry)++#if defined(HAVE_GETHOSTENT) && !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+getHostEntry :: IO HostEntry+getHostEntry = withLock $ do+ throwNoSuchThingIfNull         "getHostEntry" "unable to retrieve host entry"+   $ trySysCall $ c_gethostent+ >>= peek++foreign import ccall unsafe "gethostent" c_gethostent :: IO (Ptr HostEntry)++setHostEntry :: Bool -> IO ()+setHostEntry flg = withLock $ trySysCall $ c_sethostent (fromBool flg)++foreign import ccall unsafe "sethostent" c_sethostent :: CInt -> IO ()++endHostEntry :: IO ()+endHostEntry = withLock $ c_endhostent++foreign import ccall unsafe "endhostent" c_endhostent :: IO ()++getHostEntries :: Bool -> IO [HostEntry]+getHostEntries stayOpen = do+  setHostEntry stayOpen+  getEntries (getHostEntry) (endHostEntry)+#endif++-- ---------------------------------------------------------------------------+-- Accessing network information++-- Same set of access functions as for accessing host,protocol and+-- service system info, this time for the types of networks supported.++-- network addresses are represented in host byte order.+type NetworkAddr = CULong++type NetworkName = String++data NetworkEntry =+  NetworkEntry {+     networkName        :: NetworkName,   -- official name+     networkAliases     :: [NetworkName], -- aliases+     networkFamily      :: Family,         -- type+     networkAddress     :: NetworkAddr+   } deriving (Read, Show, Typeable)++instance Storable NetworkEntry where+   sizeOf    _ = #const sizeof(struct hostent)+   alignment _ = alignment (undefined :: CInt) -- ???++   peek p = do+        n_name         <- (#peek struct netent, n_name) p >>= peekCString+        n_aliases      <- (#peek struct netent, n_aliases) p+                                >>= peekArray0 nullPtr+                                >>= mapM peekCString+        n_addrtype     <- (#peek struct netent, n_addrtype) p+        n_net          <- (#peek struct netent, n_net) p+        return (NetworkEntry {+                        networkName      = n_name,+                        networkAliases   = n_aliases,+                        networkFamily    = unpackFamily (fromIntegral +                                                        (n_addrtype :: CInt)),+                        networkAddress   = n_net+                })++   poke _p = error "Storable.poke(BSD.NetEntry) not implemented"+++#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32)+getNetworkByName :: NetworkName -> IO NetworkEntry+getNetworkByName name = withLock $ do+ withCString name $ \ name_cstr -> do+  throwNoSuchThingIfNull "getNetworkByName" "no such network entry"+    $ trySysCall $ c_getnetbyname name_cstr+  >>= peek++foreign import ccall unsafe "getnetbyname" +   c_getnetbyname  :: CString -> IO (Ptr NetworkEntry)++getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry+getNetworkByAddr addr family = withLock $ do+ throwNoSuchThingIfNull "getNetworkByAddr" "no such network entry"+   $ trySysCall $ c_getnetbyaddr addr (packFamily family)+ >>= peek++foreign import ccall unsafe "getnetbyaddr" +   c_getnetbyaddr  :: NetworkAddr -> CInt -> IO (Ptr NetworkEntry)++getNetworkEntry :: IO NetworkEntry+getNetworkEntry = withLock $ do+ throwNoSuchThingIfNull "getNetworkEntry" "no more network entries"+          $ trySysCall $ c_getnetent+ >>= peek++foreign import ccall unsafe "getnetent" c_getnetent :: IO (Ptr NetworkEntry)++-- | Open the network name database. The parameter specifies+-- whether a connection is maintained open between various+-- networkEntry calls+setNetworkEntry :: Bool -> IO ()+setNetworkEntry flg = withLock $ trySysCall $ c_setnetent (fromBool flg)++foreign import ccall unsafe "setnetent" c_setnetent :: CInt -> IO ()++-- | Close the connection to the network name database.+endNetworkEntry :: IO ()+endNetworkEntry = withLock $ trySysCall $ c_endnetent++foreign import ccall unsafe "endnetent" c_endnetent :: IO ()++-- | Get the list of network entries.+getNetworkEntries :: Bool -> IO [NetworkEntry]+getNetworkEntries stayOpen = do+  setNetworkEntry stayOpen+  getEntries (getNetworkEntry) (endNetworkEntry)+#endif++-- Mutex for name service lockdown++{-# NOINLINE lock #-}+lock :: MVar ()+lock = unsafePerformIO $ newMVar ()++withLock :: IO a -> IO a+withLock act = withMVar lock (\_ -> act)++-- ---------------------------------------------------------------------------+-- Miscellaneous Functions++-- | Calling getHostName returns the standard host name for the current+-- processor, as set at boot time.++getHostName :: IO HostName+getHostName = do+  let size = 256+  allocaArray0 size $ \ cstr -> do+    throwSocketErrorIfMinus1_ "getHostName" $ c_gethostname cstr (fromIntegral size)+    peekCString cstr++foreign import CALLCONV unsafe "gethostname" +   c_gethostname :: CString -> CSize -> IO CInt++-- Helper function used by the exported functions that provides a+-- Haskellised view of the enumerator functions:++getEntries :: IO a  -- read+           -> IO () -- at end+           -> IO [a]+getEntries getOne atEnd = loop+  where+    loop = do+      vv <- catch (liftM Just getOne)+            (\ e -> let _types = e :: IOException in return Nothing)+      case vv of+        Nothing -> return []+        Just v  -> loop >>= \ vs -> atEnd >> return (v:vs)+++-- ---------------------------------------------------------------------------+-- Winsock only:+--   The BSD API networking calls made locally return NULL upon failure.+--   That failure may very well be due to WinSock not being initialised,+--   so if NULL is seen try init'ing and repeat the call.+#if !defined(mingw32_HOST_OS) && !defined(_WIN32)+trySysCall :: IO a -> IO a+trySysCall act = act+#else+trySysCall :: IO (Ptr a) -> IO (Ptr a)+trySysCall act = do+  ptr <- act+  if (ptr == nullPtr)+   then withSocketsDo act+   else return ptr+#endif++throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a)+throwNoSuchThingIfNull loc desc act = do+  ptr <- act+  if (ptr == nullPtr)+   then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc)+   else return ptr
+ Network/Browser.hs view
@@ -0,0 +1,1062 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-}+{- |++Module      :  Network.Browser+Copyright   :  See LICENSE file+License     :  BSD+ +Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+Stability   :  experimental+Portability :  non-portable (not tested)++Session-level interactions over HTTP.+ +The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in +providing support for more involved, and real, request/response interactions over +HTTP. Additional features supported are:++* HTTP Authentication handling++* Transparent handling of redirects++* Cookie stores + transmission.++* Transaction logging++* Proxy-mediated connections.++Example use:++>    do+>      (_, rsp)+>         <- Network.Browser.browse $ do+>               setAllowRedirects True -- handle HTTP redirects+>               request $ getRequest "http://www.haskell.org/"+>      return (take 100 (rspBody rsp))+ +-}+module Network.Browser +       ( BrowserState+       , BrowserAction      -- browser monad, effectively a state monad.+       , Proxy(..)+       +       , browse             -- :: BrowserAction a -> IO a+       , request            -- :: Request -> BrowserAction Response+    +       , getBrowserState    -- :: BrowserAction t (BrowserState t)+       , withBrowserState   -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a+       +       , setAllowRedirects  -- :: Bool -> BrowserAction t ()+       , getAllowRedirects  -- :: BrowserAction t Bool++       , setMaxRedirects    -- :: Int -> BrowserAction t ()+       , getMaxRedirects    -- :: BrowserAction t (Maybe Int)+       +       , Authority(..)+       , getAuthorities+       , setAuthorities+       , addAuthority+       , Challenge(..)+       , Qop(..)+       , Algorithm(..)+       +       , getAuthorityGen+       , setAuthorityGen+       , setAllowBasicAuth+       , getAllowBasicAuth+       +       , setMaxErrorRetries  -- :: Maybe Int -> BrowserAction t ()+       , getMaxErrorRetries  -- :: BrowserAction t (Maybe Int)++       , setMaxPoolSize     -- :: Int -> BrowserAction t ()+       , getMaxPoolSize     -- :: BrowserAction t (Maybe Int)++       , setMaxAuthAttempts  -- :: Maybe Int -> BrowserAction t ()+       , getMaxAuthAttempts  -- :: BrowserAction t (Maybe Int)++       , setCookieFilter     -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()+       , getCookieFilter     -- :: BrowserAction t (URI -> Cookie -> IO Bool)+       , defaultCookieFilter -- :: URI -> Cookie -> IO Bool+       , userCookieFilter    -- :: URI -> Cookie -> IO Bool+       +       , Cookie(..)+       , getCookies        -- :: BrowserAction t [Cookie]+       , setCookies        -- :: [Cookie] -> BrowserAction t ()+       , addCookie         -- :: Cookie   -> BrowserAction t ()+       +       , setErrHandler     -- :: (String -> IO ()) -> BrowserAction t ()+       , setOutHandler     -- :: (String -> IO ()) -> BrowserAction t ()+    +       , setEventHandler   -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t ()+       +       , BrowserEvent(..)+       , BrowserEventType(..)+       , RequestID+       +       , setProxy         -- :: Proxy -> BrowserAction t ()+       , getProxy         -- :: BrowserAction t Proxy++       , setCheckForProxy -- :: Bool -> BrowserAction t ()+       , getCheckForProxy -- :: BrowserAction t Bool++       , setDebugLog      -- :: Maybe String -> BrowserAction t ()+       +       , getUserAgent     -- :: BrowserAction t String+       , setUserAgent     -- :: String -> BrowserAction t ()+       +       , out              -- :: String -> BrowserAction t ()+       , err              -- :: String -> BrowserAction t ()+       , ioAction         -- :: IO a -> BrowserAction a++       , defaultGETRequest+       , defaultGETRequest_+       +       , formToRequest+       , uriDefaultTo+       +         -- old and half-baked; don't use:+       , Form(..)+       , FormVar+       ) where++import Network.URI+   ( URI(..)+   , URIAuth(..)+   , parseURI, parseURIReference, relativeTo+   )+import Network.StreamDebugger (debugByteStream)+import Network.HTTP hiding ( sendHTTP_notify )+import Network.HTTP.HandleStream ( sendHTTP_notify )+import Network.HTTP.Auth+import Network.HTTP.Cookie+import Network.HTTP.Proxy++import Network.Stream ( ConnError(..), Result )+import Network.BufferType++import Data.Char (toLower)+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes )+import Control.Applicative (Applicative (..), (<$>))+#ifdef MTL1+import Control.Monad (filterM, when, ap)+#else+import Control.Monad (filterM, when)+#endif+import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..))++import qualified System.IO+   ( hSetBuffering, hPutStr, stdout, stdin, hGetChar+   , BufferMode(NoBuffering, LineBuffering)+   )+import System.Time ( ClockTime, getClockTime )+++------------------------------------------------------------------+----------------------- Cookie Stuff -----------------------------+------------------------------------------------------------------++-- | @defaultCookieFilter@ is the initial cookie acceptance filter.+-- It welcomes them all into the store @:-)@+defaultCookieFilter :: URI -> Cookie -> IO Bool+defaultCookieFilter _url _cky = return True++-- | @userCookieFilter@ is a handy acceptance filter, asking the+-- user if he/she is willing to accept an incoming cookie before+-- adding it to the store.+userCookieFilter :: URI -> Cookie -> IO Bool+userCookieFilter url cky = do+    do putStrLn ("Set-Cookie received when requesting: " ++ show url)+       case ckComment cky of+          Nothing -> return ()+          Just x  -> putStrLn ("Cookie Comment:\n" ++ x)+       let pth = maybe "" ('/':) (ckPath cky)+       putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth)+       putStrLn (ckName cky ++ '=' : ckValue cky)+       System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering+       System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering+       System.IO.hPutStr System.IO.stdout "Accept [y/n]? "+       x <- System.IO.hGetChar System.IO.stdin+       System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering+       System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering+       return (toLower x == 'y')++-- | @addCookie c@ adds a cookie to the browser state, removing duplicates.+addCookie :: Cookie -> BrowserAction t ()+addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })++-- | @setCookies cookies@ replaces the set of cookies known to+-- the browser to @cookies@. Useful when wanting to restore cookies+-- used across 'browse' invocations.+setCookies :: [Cookie] -> BrowserAction t ()+setCookies cs = modify (\b -> b { bsCookies=cs })++-- | @getCookies@ returns the current set of cookies known to+-- the browser.+getCookies :: BrowserAction t [Cookie]+getCookies = gets bsCookies++-- ...get domain specific cookies...+-- ... this needs changing for consistency with rfc2109...+-- ... currently too broad.+getCookiesFor :: String -> String -> BrowserAction t [Cookie]+getCookiesFor dom path =+    do cks <- getCookies+       return (filter cookiematch cks)+    where+        cookiematch :: Cookie -> Bool+        cookiematch = cookieMatch (dom,path)+      ++-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@.+setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()+setCookieFilter f = modify (\b -> b { bsCookieFilter=f })++-- | @getCookieFilter@ returns the current cookie acceptance filter.+getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)+getCookieFilter = gets bsCookieFilter++------------------------------------------------------------------+----------------------- Authorisation Stuff ----------------------+------------------------------------------------------------------++{-++The browser handles 401 responses in the following manner:+  1) extract all WWW-Authenticate headers from a 401 response+  2) rewrite each as a Challenge object, using "headerToChallenge"+  3) pick a challenge to respond to, usually the strongest+     challenge understood by the client, using "pickChallenge"+  4) generate a username/password combination using the browsers+     "bsAuthorityGen" function (the default behaviour is to ask+     the user)+  5) build an Authority object based upon the challenge and user+     data, store this new Authority in the browser state+  6) convert the Authority to a request header and add this+     to a request using "withAuthority"+  7) send the amended request++Note that by default requests are annotated with authority headers+before the first sending, based upon previously generated Authority+objects (which contain domain information).  Once a specific authority+is added to a rejected request this predictive annotation is suppressed.++407 responses are handled in a similar manner, except+   a) Authorities are not collected, only a single proxy authority+      is kept by the browser+   b) If the proxy used by the browser (type Proxy) is NoProxy, then+      a 407 response will generate output on the "err" stream and+      the response will be returned.+++Notes:+ - digest authentication so far ignores qop, so fails to authenticate +   properly with qop=auth-int challenges+ - calculates a1 more than necessary+ - doesn't reverse authenticate+ - doesn't properly receive AuthenticationInfo headers, so fails+   to use next-nonce etc++-}++-- | Return authorities for a given domain and path.+-- Assumes "dom" is lower case+getAuthFor :: String -> String -> BrowserAction t [Authority]+getAuthFor dom pth = getAuthorities >>= return . (filter match)+   where+    match :: Authority -> Bool+    match au@AuthBasic{}  = matchURI (auSite au)+    match au@AuthDigest{} = or (map matchURI (auDomain au))++    matchURI :: URI -> Bool+    matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)+    ++-- | @getAuthorities@ return the current set of @Authority@s known+-- to the browser.+getAuthorities :: BrowserAction t [Authority]+getAuthorities = gets bsAuthorities++-- @setAuthorities as@ replaces the Browser's known set+-- of 'Authority's to @as@.+setAuthorities :: [Authority] -> BrowserAction t ()+setAuthorities as = modify (\b -> b { bsAuthorities=as })++-- @addAuthority a@ adds 'Authority' @a@ to the Browser's+-- set of known authorities.+addAuthority :: Authority -> BrowserAction t ()+addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b })++-- | @getAuthorityGen@ returns the current authority generator+getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))+getAuthorityGen = gets bsAuthorityGen++-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@.+setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()+setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f })++-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication.+setAllowBasicAuth :: Bool -> BrowserAction t ()+setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba })++getAllowBasicAuth :: BrowserAction t Bool+getAllowBasicAuth = gets bsAllowBasicAuth++-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts+-- to do. If @Nothing@, rever to default max.+setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()+setMaxAuthAttempts mb + | fromMaybe 0 mb < 0 = return ()+ | otherwise          = modify (\ b -> b{bsMaxAuthAttempts=mb})++-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@,+-- the browser's default is used.+getMaxAuthAttempts :: BrowserAction t (Maybe Int)+getMaxAuthAttempts = gets bsMaxAuthAttempts++-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at+-- transmitting a request. If @Nothing@, rever to default max.+setMaxErrorRetries :: Maybe Int -> BrowserAction t ()+setMaxErrorRetries mb+ | fromMaybe 0 mb < 0 = return ()+ | otherwise          = modify (\ b -> b{bsMaxErrorRetries=mb})++-- | @getMaxErrorRetries@ returns the current max number of error retries.+getMaxErrorRetries :: BrowserAction t (Maybe Int)+getMaxErrorRetries = gets bsMaxErrorRetries++-- TO BE CHANGED!!!+pickChallenge :: Bool -> [Challenge] -> Maybe Challenge+pickChallenge allowBasic []+ | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust.+pickChallenge _ ls = listToMaybe ls++-- | Retrieve a likely looking authority for a Request.+anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority)+anticipateChallenge rq =+    let uri = rqURI rq in+    do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri)+       ; return (listToMaybe authlist)+       }++-- | Asking the user to respond to a challenge+challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)+challengeToAuthority uri ch+ | not (answerable ch) = return Nothing+ | otherwise = do+      -- prompt user for authority+    prompt <- getAuthorityGen+    userdetails <- liftIO $ prompt uri (chRealm ch)+    case userdetails of+     Nothing    -> return Nothing+     Just (u,p) -> return (Just $ buildAuth ch u p)+ where+  answerable :: Challenge -> Bool+  answerable ChalBasic{} = True+  answerable chall       = (chAlgorithm chall) == Just AlgMD5++  buildAuth :: Challenge -> String -> String -> Authority+  buildAuth (ChalBasic r) u p = +       AuthBasic { auSite=uri+                 , auRealm=r+                 , auUsername=u+                 , auPassword=p+                 }++    -- note to self: this is a pretty stupid operation+    -- to perform isn't it? ChalX and AuthX are so very+    -- similar.+  buildAuth (ChalDigest r d n o _stale a q) u p =+            AuthDigest { auRealm=r+                       , auUsername=u+                       , auPassword=p+                       , auDomain=d+                       , auNonce=n+                       , auOpaque=o+                       , auAlgorithm=a+                       , auQop=q+                       }+++------------------------------------------------------------------+------------------ Browser State Actions -------------------------+------------------------------------------------------------------+++-- | @BrowserState@ is the (large) record type tracking the current+-- settings of the browser.+data BrowserState connection+ = BS { bsErr, bsOut      :: String -> IO ()+      , bsCookies         :: [Cookie]+      , bsCookieFilter    :: URI -> Cookie -> IO Bool+      , bsAuthorityGen    :: URI -> String -> IO (Maybe (String,String))+      , bsAuthorities     :: [Authority]+      , bsAllowRedirects  :: Bool+      , bsAllowBasicAuth  :: Bool+      , bsMaxRedirects    :: Maybe Int+      , bsMaxErrorRetries :: Maybe Int+      , bsMaxAuthAttempts :: Maybe Int+      , bsMaxPoolSize     :: Maybe Int+      , bsConnectionPool  :: [connection]+      , bsCheckProxy      :: Bool+      , bsProxy           :: Proxy+      , bsDebug           :: Maybe String+      , bsEvent           :: Maybe (BrowserEvent -> BrowserAction connection ())+      , bsRequestID       :: RequestID+      , bsUserAgent       :: Maybe String+      }++instance Show (BrowserState t) where+    show bs =  "BrowserState { " +            ++ shows (bsCookies bs) ("\n"+           {- ++ show (bsAuthorities bs) ++ "\n"-}+            ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")++-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.+newtype BrowserAction conn a+ = BA { unBA :: StateT (BrowserState conn) IO a }+#ifdef MTL1+ deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn))++instance Applicative (BrowserAction conn) where+  pure  = return+  (<*>) = ap+#else+ deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn))+#endif++runBA :: BrowserState conn -> BrowserAction conn a -> IO a+runBA bs = flip evalStateT bs . unBA++-- | @browse act@ is the toplevel action to perform a 'BrowserAction'.+-- Example use: @browse (request (getRequest yourURL))@.+browse :: BrowserAction conn a -> IO a+browse = runBA defaultBrowserState++-- | The default browser state has the settings +defaultBrowserState :: BrowserState t+defaultBrowserState = res+ where+   res = BS+     { bsErr              = putStrLn+     , bsOut              = putStrLn+     , bsCookies          = []+     , bsCookieFilter     = defaultCookieFilter+     , bsAuthorityGen     = \ _uri _realm -> do+          bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"+          return Nothing+     , bsAuthorities      = []+     , bsAllowRedirects   = True+     , bsAllowBasicAuth   = False+     , bsMaxRedirects     = Nothing+     , bsMaxErrorRetries  = Nothing+     , bsMaxAuthAttempts  = Nothing+     , bsMaxPoolSize      = Nothing+     , bsConnectionPool   = []+     , bsCheckProxy       = defaultAutoProxyDetect+     , bsProxy            = noProxy+     , bsDebug            = Nothing +     , bsEvent            = Nothing+     , bsRequestID        = 0+     , bsUserAgent        = Nothing+     }++{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-}+-- | @getBrowserState@ returns the current browser config. Useful+-- for restoring state across 'BrowserAction's.+getBrowserState :: BrowserAction t (BrowserState t)+getBrowserState = get++-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@.+withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a+withBrowserState bs = BA . withStateT (const bs) . unBA++-- | @nextRequest act@ performs the browser action @act@ as+-- the next request, i.e., setting up a new request context+-- before doing so.+nextRequest :: BrowserAction t a -> BrowserAction t a+nextRequest act = do+  let updReqID st = +       let +        rid = succ (bsRequestID st)+       in+       rid `seq` st{bsRequestID=rid}+  modify updReqID+  act++-- | Lifts an IO action into the 'BrowserAction' monad.+{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-}+ioAction :: IO a -> BrowserAction t a+ioAction = liftIO++-- | @setErrHandler@ sets the IO action to call when+-- the browser reports running errors. To disable any+-- such, set it to @const (return ())@.+setErrHandler :: (String -> IO ()) -> BrowserAction t ()+setErrHandler h = modify (\b -> b { bsErr=h })++-- | @setErrHandler@ sets the IO action to call when+-- the browser chatters info on its running. To disable any+-- such, set it to @const (return ())@.+setOutHandler :: (String -> IO ()) -> BrowserAction t ()+setOutHandler h = modify (\b -> b { bsOut=h })++out, err :: String -> BrowserAction t ()+out s = do { f <- gets bsOut ; liftIO $ f s }+err s = do { f <- gets bsErr ; liftIO $ f s }++-- | @setAllowRedirects onOff@ toggles the willingness to+-- follow redirects (HTTP responses with 3xx status codes).+setAllowRedirects :: Bool -> BrowserAction t ()+setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl})++-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag.+getAllowRedirects :: BrowserAction t Bool+getAllowRedirects = gets bsAllowRedirects++-- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops+-- we are willing to jump through. A no-op if the count is negative; if zero,+-- the max is set to whatever default applies. Notice that setting the max+-- redirects count does /not/ enable following of redirects itself; use+-- 'setAllowRedirects' to do so.+setMaxRedirects :: Maybe Int -> BrowserAction t ()+setMaxRedirects c + | fromMaybe 0 c < 0  = return ()+ | otherwise          = modify (\b -> b{bsMaxRedirects=c})++-- | @getMaxRedirects@ returns the current setting for the max-redirect count.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxRedirects :: BrowserAction t (Maybe Int)+getMaxRedirects = gets bsMaxRedirects++-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool+-- that is used to cache connections between requests+setMaxPoolSize :: Maybe Int -> BrowserAction t ()+setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c})++-- | @getMaxPoolSize@ gets the maximum size of the connection pool+-- that is used to cache connections between requests.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxPoolSize :: BrowserAction t (Maybe Int)+getMaxPoolSize = gets bsMaxPoolSize++-- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@.+-- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted+-- as the URL of the proxy to use, possibly authenticating via +-- 'Authority' information in @mbAuth@.+setProxy :: Proxy -> BrowserAction t ()+setProxy p =+   -- Note: if user _explicitly_ sets the proxy, we turn+   -- off any auto-detection of proxies.+  modify (\b -> b {bsProxy = p, bsCheckProxy=False})++-- | @getProxy@ returns the current proxy settings. If+-- the auto-proxy flag is set to @True@, @getProxy@ will+-- perform the necessary +getProxy :: BrowserAction t Proxy+getProxy = do+  p <- gets bsProxy+  case p of+      -- Note: if there is a proxy, no need to perform any auto-detect.+      -- Presumably this is the user's explicit and preferred proxy server.+    Proxy{} -> return p+    NoProxy{} -> do+     flg <- gets bsCheckProxy+     if not flg+      then return p +      else do+       np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-}+        -- note: this resets the check-proxy flag; a one-off affair.+       setProxy np+       return np++-- | @setCheckForProxy flg@ sets the one-time check for proxy+-- flag to @flg@. If @True@, the session will try to determine+-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy'+-- for details of how this done.+setCheckForProxy :: Bool -> BrowserAction t ()+setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg})++-- | @getCheckForProxy@ returns the current check-proxy setting.+-- Notice that this may not be equal to @True@ if the session has+-- set it to that via 'setCheckForProxy' and subsequently performed+-- some HTTP protocol interactions. i.e., the flag return represents+-- whether a proxy will be checked for again before any future protocol+-- interactions.+getCheckForProxy :: BrowserAction t Bool+getCheckForProxy = gets bsCheckProxy++-- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@+-- is @Nothing@. If set to @Just fStem@, logs of browser activity+-- is appended to files of the form @fStem-url-authority@, i.e.,+-- @fStem@ is just the prefix for a set of log files, one per host/authority.+setDebugLog :: Maybe String -> BrowserAction t ()+setDebugLog v = modify (\b -> b {bsDebug=v})++-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It+-- will be used if no explicit user agent header is found in subsequent requests.+--+-- A common form of user agent string is @\"name\/version (details)\"@. For+-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version+-- of this HTTP package can be helpful if you ever need to track down HTTP+-- compatability quirks. This version is available via 'httpPackageVersion'.+-- For more info see <http://en.wikipedia.org/wiki/User_agent>.+--+setUserAgent :: String -> BrowserAction t ()+setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua})++-- | @getUserAgent@ returns the current @User-Agent:@ default string.+getUserAgent :: BrowserAction t String+getUserAgent  = do+  n <- gets bsUserAgent+  return (maybe defaultUserAgent id n)++-- | @RequestState@ is an internal tallying type keeping track of various +-- per-connection counters, like the number of authorization attempts and +-- forwards we've gone through.+data RequestState +  = RequestState+      { reqDenies     :: Int   -- ^ number of 401 responses so far+      , reqRedirects  :: Int   -- ^ number of redirects so far+      , reqRetries    :: Int   -- ^ number of retries so far+      , reqStopOnDeny :: Bool  -- ^ whether to pre-empt 401 response+      }++type RequestID = Int -- yeah, it will wrap around.++nullRequestState :: RequestState+nullRequestState = RequestState+      { reqDenies     = 0+      , reqRedirects  = 0+      , reqRetries    = 0+      , reqStopOnDeny = True+      }++-- | @BrowserEvent@ is the event record type that a user-defined handler, set+-- via 'setEventHandler', will be passed. It indicates various state changes+-- encountered in the processing of a given 'RequestID', along with timestamps+-- at which they occurred.+data BrowserEvent+ = BrowserEvent+      { browserTimestamp  :: ClockTime+      , browserRequestID  :: RequestID+      , browserRequestURI :: {-URI-}String+      , browserEventType  :: BrowserEventType+      }++-- | 'BrowserEventType' is the enumerated list of events that the browser+-- internals will report to a user-defined event handler.+data BrowserEventType+ = OpenConnection+ | ReuseConnection+ | RequestSent+ | ResponseEnd ResponseData+ | ResponseFinish+{- not yet, you will have to determine these via the ResponseEnd event.+ | Redirect+ | AuthChallenge+ | AuthResponse+-}+ +-- | @setEventHandler onBrowserEvent@ configures event handling.+-- If @onBrowserEvent@ is @Nothing@, event handling is turned off;+-- setting it to @Just onEv@ causes the @onEv@ IO action to be+-- notified of browser events during the processing of a request+-- by the Browser pipeline.+setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()+setEventHandler mbH = modify (\b -> b { bsEvent=mbH})++buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent+buildBrowserEvent bt uri reqID = do+  ct <- getClockTime+  return BrowserEvent +         { browserTimestamp  = ct+         , browserRequestID  = reqID+         , browserRequestURI = uri+         , browserEventType  = bt+         }++reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t ()+reportEvent bt uri = do+  st <- get+  case bsEvent st of+    Nothing -> return ()+    Just evH -> do+       evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st)+       evH evt -- if it fails, we fail.++-- | The default number of hops we are willing not to go beyond for +-- request forwardings.+defaultMaxRetries :: Int+defaultMaxRetries = 4++-- | The default number of error retries we are willing to perform.+defaultMaxErrorRetries :: Int+defaultMaxErrorRetries = 4++-- | The default maximum HTTP Authentication attempts we will make for+-- a single request.+defaultMaxAuthAttempts :: Int+defaultMaxAuthAttempts = 2++-- | The default setting for auto-proxy detection.+-- You may change this within a session via 'setAutoProxyDetect'.+-- To avoid initial backwards compatibility issues, leave this as @False@.+defaultAutoProxyDetect :: Bool+defaultAutoProxyDetect = False++-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@+-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.)+-- Upon successful delivery, the URL where the response was fetched from+-- is returned along with the 'Response' itself.+request :: HStream ty+        => Request ty+	-> BrowserAction (HandleStream ty) (URI,Response ty)+request req = nextRequest $ do+  res <- request' nullVal initialState req+  reportEvent ResponseFinish (show (rqURI req))+  case res of+    Right r -> return r+    Left e  -> do+     let errStr = ("Network.Browser.request: Error raised " ++ show e)+     err errStr+     fail errStr+ where+  initialState = nullRequestState+  nullVal      = buf_empty bufferOps++-- | Internal helper function, explicitly carrying along per-request +-- counts.+request' :: HStream ty+         => ty+	 -> RequestState+	 -> Request ty+	 -> BrowserAction (HandleStream ty) (Result (URI,Response ty))+request' nullVal rqState rq = do+   let uri = rqURI rq+   failHTTPS uri+   let uria = reqURIAuth rq +     -- add cookies to request+   cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri)+{- Not for now:+   (case uriUserInfo uria of+     "" -> id+     xs ->+       case chopAtDelim ':' xs of+         (_,[])    -> id+	 (usr,pwd) -> withAuth+	                  AuthBasic{ auUserName = usr+                                   , auPassword = pwd+			           , auRealm    = "/"+			           , auSite     = uri+			           }) $ do+-}+   when (not $ null cookies) +        (out $ "Adding cookies to request.  Cookie names: "  ++ unwords (map ckName cookies))+    -- add credentials to request+   rq' <- +    if not (reqStopOnDeny rqState) +     then return rq +     else do +       auth <- anticipateChallenge rq+       case auth of+         Nothing -> return rq+         Just x  -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)+   let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq'+   p <- getProxy+   def_ua <- gets bsUserAgent+   let defaultOpts = +         case p of +	   NoProxy     -> defaultNormalizeRequestOptions{normUserAgent=def_ua}+	   Proxy _ ath ->+	      defaultNormalizeRequestOptions+	        { normForProxy  = True+		, normUserAgent = def_ua+		, normCustoms   = +		    maybe []+		          (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])+			  ath+		}+   let final_req = normalizeRequest defaultOpts rq''+   out ("Sending:\n" ++ show final_req)+   e_rsp <- +     case p of+       NoProxy        -> dorequest (reqURIAuth rq'') final_req+       Proxy str _ath -> do+          let notURI +	       | null pt || null hst = +	         URIAuth{ uriUserInfo = ""+	                , uriRegName  = str+			, uriPort     = ""+			}+	       | otherwise = +	         URIAuth{ uriUserInfo = ""+	                , uriRegName  = hst+			, uriPort     = pt+			}+                  -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it!+                 where (hst, pt) = span (':'/=) str+           -- Proxy can take multiple forms - look for http://host:port first,+           -- then host:port. Fall back to just the string given (probably a host name).+          let proxyURIAuth =+                maybe notURI+                      (\parsed -> maybe notURI id (uriAuthority parsed))+                      (parseURI str)++          out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth+	  dorequest proxyURIAuth final_req+   mbMx <- getMaxErrorRetries+   case e_rsp of+    Left v +     | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && +       (v == ErrorReset || v == ErrorClosed) ->+       request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq+     | otherwise -> +       return (Left v)+    Right rsp -> do +     out ("Received:\n" ++ show rsp)+      -- add new cookies to browser state+     handleCookies uri (uriAuthToString $ reqURIAuth rq) +                       (retrieveHeaders HdrSetCookie rsp)+     mbMxAuths <- getMaxAuthAttempts+     case rspCode rsp of+      (4,0,1) -- Credentials not sent or refused.+        | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do+          out "401 - credentials again refused; exceeded retry count (2)"+	  return (Right (uri,rsp))+	| otherwise -> do+          out "401 - credentials not supplied or refused; retrying.."+          let hdrs = retrieveHeaders HdrWWWAuthenticate rsp+	  flg <- getAllowBasicAuth+          case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of+            Nothing -> do+	      out "no challenge"+	      return (Right (uri,rsp))   {- do nothing -}+            Just x  -> do+              au <- challengeToAuthority uri x+              case au of+                Nothing  -> do+		  out "no auth"+		  return (Right (uri,rsp)) {- do nothing -}+                Just au' -> do+                  out "Retrying request with new credentials"+		  request' nullVal+			   rqState{ reqDenies     = succ(reqDenies rqState)+			          , reqStopOnDeny = False+				  }+                           (insertHeader HdrAuthorization (withAuthority au' rq) rq)++      (4,0,7)  -- Proxy Authentication required+        | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do+          out "407 - proxy authentication required; max deny count exceeeded (2)"+          return (Right (uri,rsp))+        | otherwise -> do+          out "407 - proxy authentication required"+          let hdrs = retrieveHeaders HdrProxyAuthenticate rsp+	  flg <- getAllowBasicAuth+          case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of+            Nothing -> return (Right (uri,rsp))   {- do nothing -}+            Just x  -> do+              au <- challengeToAuthority uri x+              case au of+               Nothing  -> return (Right (uri,rsp))  {- do nothing -}+               Just au' -> do+                 pxy <- gets bsProxy+                 case pxy of+                   NoProxy -> do+                     err "Proxy authentication required without proxy!"+                     return (Right (uri,rsp))+                   Proxy px _ -> do+                     out "Retrying with proxy authentication"+                     setProxy (Proxy px (Just au'))+                     request' nullVal+			      rqState{ reqDenies     = succ(reqDenies rqState)+			             , reqStopOnDeny = False+				     }+			      rq++      (3,0,x) | x `elem` [2,3,1,7]  ->  do+        out ("30" ++ show x ++  " - redirect")+	allow_redirs <- allowRedirect rqState+	case allow_redirs of+	  False -> return (Right (uri,rsp))+	  _ -> do+           case retrieveHeaders HdrLocation rsp of+            [] -> do +	      err "No Location: header in redirect response"+              return (Right (uri,rsp))+            (Header _ u:_) -> +	      case parseURIReference u of+                Nothing -> do+                  err ("Parse of Location: header in a redirect response failed: " ++ u)+                  return (Right (uri,rsp))+                Just newURI+	         | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do+	            err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)+	            return (Right (uri, rsp))+                 | otherwise -> do		     +  	            out ("Redirecting to " ++ show newURI_abs ++ " ...") +                    +                    -- Redirect using GET request method, depending on+                    -- response code.+                    let toGet = x `elem` [2,3]+                        method = if toGet then GET else rqMethod rq+                        rq1 = rq { rqMethod=method, rqURI=newURI_abs }+                        rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1+                    +                    request' nullVal+	         	    rqState{ reqDenies     = 0+	         	           , reqRedirects  = succ(reqRedirects rqState)+	         		   , reqStopOnDeny = True+	         		   }+                             rq2+                 where+                   newURI_abs = maybe newURI id (newURI `relativeTo` uri)++      (3,0,5) ->+        case retrieveHeaders HdrLocation rsp of+         [] -> do +	   err "No Location header in proxy redirect response."+           return (Right (uri,rsp))+         (Header _ u:_) -> +	   case parseURIReference u of+            Nothing -> do+             err ("Parse of Location header in a proxy redirect response failed: " ++ u)+             return (Right (uri,rsp))+            Just newuri -> do+             out ("Retrying with proxy " ++ show newuri ++ "...")+             setProxy (Proxy (uriToAuthorityString newuri) Nothing)+             request' nullVal rqState{ reqDenies     = 0+	                             , reqRedirects  = 0+				     , reqRetries    = succ (reqRetries rqState)+				     , reqStopOnDeny = True+				     }+				     rq+      _       -> return (Right (uri,rsp))++-- | The internal request handling state machine.+dorequest :: (HStream ty)+          => URIAuth+	  -> Request ty+	  -> BrowserAction (HandleStream ty)+	                   (Result (Response ty))+dorequest hst rqst = do+  pool <- gets bsConnectionPool+  let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst+  conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool+  rsp <- +    case conn of+      [] -> do +        out ("Creating new connection to " ++ uriAuthToString hst)+	reportEvent OpenConnection (show (rqURI rqst))+        c <- liftIO $ openStream (uriRegName hst) uPort+	updateConnectionPool c+	dorequest2 c rqst+      (c:_) -> do+        out ("Recovering connection to " ++ uriAuthToString hst)+	reportEvent ReuseConnection (show (rqURI rqst))+        dorequest2 c rqst+  case rsp of +     Right (Response a b c _) -> +         reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return ()+  return rsp+ where+  dorequest2 c r = do+    dbg <- gets bsDebug+    st  <- get+    let +     onSendComplete =+       maybe (return ())+             (\evh -> do+	        x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)+		runBA st (evh x)+		return ())+             (bsEvent st)+    liftIO $ +      maybe (sendHTTP_notify c r onSendComplete)+            (\ f -> do+               c' <- debugByteStream (f++'-': uriAuthToString hst) c+	       sendHTTP_notify c' r onSendComplete)+	    dbg++updateConnectionPool :: HStream hTy+                     => HandleStream hTy+		     -> BrowserAction (HandleStream hTy) ()+updateConnectionPool c = do+   pool <- gets bsConnectionPool+   let len_pool = length pool+   maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize+   when (len_pool > maxPoolSize)+        (liftIO $ close (last pool))+   let pool' +	| len_pool > maxPoolSize = init pool+	| otherwise              = pool+   when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' })+   return ()+                             +-- | Default maximum number of open connections we are willing to have active.+defaultMaxPoolSize :: Int+defaultMaxPoolSize = 5++handleCookies :: URI -> String -> [Header] -> BrowserAction t ()+handleCookies _   _              [] = return () -- cut short the silliness.+handleCookies uri dom cookieHeaders = do+  when (not $ null errs)+       (err $ unlines ("Errors parsing these cookie values: ":errs))+  when (not $ null newCookies)+       (out $ foldl (\x y -> x ++ "\n  " ++ show y) "Cookies received:" newCookies)+  filterfn    <- getCookieFilter+  newCookies' <- liftIO (filterM (filterfn uri) newCookies)+  when (not $ null newCookies')+       (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies'))+  mapM_ addCookie newCookies'+ where+  (errs, newCookies) = processCookieHeaders dom cookieHeaders++------------------------------------------------------------------+----------------------- Miscellaneous ----------------------------+------------------------------------------------------------------++allowRedirect :: RequestState -> BrowserAction t Bool+allowRedirect rqState = do+  rd <- getAllowRedirects+  mbMxRetries <- getMaxRedirects+  return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries))++-- | Return @True@ iff the package is able to handle requests and responses+-- over it.+supportedScheme :: URI -> Bool+supportedScheme u = uriScheme u == "http:"++-- | @uriDefaultTo a b@ returns a URI that is consistent with the first+-- argument URI @a@ when read in the context of the second URI @b@.+-- If the second argument is not sufficient context for determining+-- a full URI then anarchy reins.+uriDefaultTo :: URI -> URI -> URI+uriDefaultTo a b = maybe a id (a `relativeTo` b)+++-- This form junk is completely untested...++type FormVar = (String,String)++data Form = Form RequestMethod URI [FormVar]++formToRequest :: Form -> Request_String+formToRequest (Form m u vs) =+    let enc = urlEncodeVars vs+    in case m of+        GET -> Request { rqMethod=GET+                       , rqHeaders=[ Header HdrContentLength "0" ]+                       , rqBody=""+                       , rqURI=u { uriQuery= '?' : enc }  -- What about old query?+                       }+        POST -> Request { rqMethod=POST+                        , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded",+                                      Header HdrContentLength (show $ length enc) ]+                        , rqBody=enc+                        , rqURI=u+                        }+        _ -> error ("unexpected request: " ++ show m)++
+ Network/BufferType.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.BufferType+-- Description :  Abstract representation of request and response buffer types.+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- In order to give the user freedom in how request and response content+-- is represented, a sufficiently abstract representation is needed of+-- these internally. The "Network.BufferType" module provides this, defining+-- the 'BufferType' class and its ad-hoc representation of buffer operations+-- via the 'BufferOp' record.+--+-- This module provides definitions for the standard buffer types that the+-- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.)+-- +-----------------------------------------------------------------------------+module Network.BufferType+       ( +         BufferType(..)++       , BufferOp(..)+       , strictBufferOp+       , lazyBufferOp+       , stringBufferOp+       ) where+++import qualified Data.ByteString       as Strict hiding ( unpack, pack, span )+import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span )+import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span )+import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span )+import System.IO ( Handle )+import Data.Word ( Word8 )++import Network.HTTP.Utils ( crlf, lf )++-- | The @BufferType@ class encodes, in a mixed-mode way, the interface+-- that the library requires to operate over data embedded in HTTP+-- requests and responses. That is, we use explicit dictionaries+-- for the operations, but overload the name of the dicts themselves.+-- +class BufferType bufType where+   bufferOps :: BufferOp bufType++instance BufferType Lazy.ByteString where+   bufferOps = lazyBufferOp++instance BufferType Strict.ByteString where+   bufferOps = strictBufferOp++instance BufferType String where+   bufferOps = stringBufferOp++-- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- a Handle in an (explicit) dictionary type. May not be needed, but gives+-- us flexibility in explicit overriding and wrapping up of these methods.+--+-- Along with IO operations is an ad-hoc collection of functions for working+-- with these abstract buffers, as needed by the internals of the code+-- that processes requests and responses.+--+-- We supply three default @BufferOp@ values, for @String@ along with the+-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@+-- definitions for +data BufferOp a+ = BufferOp+     { buf_hGet         :: Handle -> Int -> IO a+     , buf_hGetContents :: Handle -> IO a+     , buf_hPut         :: Handle -> a   -> IO ()+     , buf_hGetLine     :: Handle -> IO a+     , buf_empty        :: a+     , buf_append       :: a -> a -> a+     , buf_concat       :: [a] -> a+     , buf_fromStr      :: String -> a+     , buf_toStr        :: a -> String+     , buf_snoc         :: a -> Word8 -> a+     , buf_splitAt      :: Int -> a -> (a,a)+     , buf_span         :: (Char  -> Bool) -> a -> (a,a)+     , buf_isLineTerm   :: a -> Bool+     , buf_isEmpty      :: a -> Bool+     }++instance Eq (BufferOp a) where+  _ == _ = False++-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s,+-- the non-lazy kind.+strictBufferOp :: BufferOp Strict.ByteString+strictBufferOp = +    BufferOp +      { buf_hGet         = Strict.hGet+      , buf_hGetContents = Strict.hGetContents+      , buf_hPut         = Strict.hPut+      , buf_hGetLine     = Strict.hGetLine+      , buf_append       = Strict.append+      , buf_concat       = Strict.concat+      , buf_fromStr      = Strict.pack+      , buf_toStr        = Strict.unpack+      , buf_snoc         = Strict.snoc+      , buf_splitAt      = Strict.splitAt+      , buf_span         = Strict.span+      , buf_empty        = Strict.empty+      , buf_isLineTerm   = \ b -> Strict.length b == 2 && p_crlf == b ||+                                  Strict.length b == 1 && p_lf   == b+      , buf_isEmpty      = Strict.null +      }+   where+    p_crlf = Strict.pack crlf+    p_lf   = Strict.pack lf++-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s,+-- the non-strict kind.+lazyBufferOp :: BufferOp Lazy.ByteString+lazyBufferOp = +    BufferOp +      { buf_hGet         = Lazy.hGet+      , buf_hGetContents = Lazy.hGetContents+      , buf_hPut         = Lazy.hPut+      , buf_hGetLine     = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l])+      , buf_append       = Lazy.append+      , buf_concat       = Lazy.concat+      , buf_fromStr      = Lazy.pack+      , buf_toStr        = Lazy.unpack+      , buf_snoc         = Lazy.snoc+      , buf_splitAt      = \ i x -> Lazy.splitAt (fromIntegral i) x+      , buf_span         = Lazy.span+      , buf_empty        = Lazy.empty+      , buf_isLineTerm   = \ b -> Lazy.length b == 2 && p_crlf == b ||+                                  Lazy.length b == 1 && p_lf   == b+      , buf_isEmpty      = Lazy.null +      }+   where+    p_crlf = Lazy.pack crlf+    p_lf   = Lazy.pack lf++-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s.+-- It is defined in terms of @strictBufferOp@ operations,+-- unpacking/converting to @String@ when needed.+stringBufferOp :: BufferOp String+stringBufferOp =BufferOp +      { buf_hGet         = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack+      , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack+      , buf_hPut         = \ h s -> buf_hPut strictBufferOp h (Strict.pack s)+      , buf_hGetLine     = \ h   -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack+      , buf_append       = (++)+      , buf_concat       = concat+      , buf_fromStr      = id+      , buf_toStr        = id+      , buf_snoc         = \ a x -> a ++ [toEnum (fromIntegral x)]+      , buf_splitAt      = splitAt+      , buf_span         = \ p a -> +                             case Strict.span p (Strict.pack a) of+			       (x,y) -> (Strict.unpack x, Strict.unpack y)+      , buf_empty        = []+      , buf_isLineTerm   = \ b -> b == crlf || b == lf+      , buf_isEmpty      = null +      }+
+ Network/HTTP.hs view
@@ -0,0 +1,229 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- The 'Network.HTTP' module provides a simple interface for sending and+-- receiving content over HTTP in Haskell. Here's how to fetch a document from+-- a URL and return it as a String:+--+-- >+-- >    simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody+-- >        -- fetch document and return it (as a 'String'.)+--+-- Other functions let you control the submission and transfer of HTTP+-- 'Request's and 'Response's more carefully, letting you integrate the use+-- of 'Network.HTTP' functionality into your application.+--+-- The module also exports the main types of the package, 'Request' and 'Response',+-- along with 'Header' and functions for working with these.+--+-- The actual functionality is implemented by modules in the @Network.HTTP.*@+-- namespace, letting you either use the default implementation here+-- by importing @Network.HTTP@ or, for more specific uses, selectively+-- import the modules in @Network.HTTP.*@. To wit, more than one kind of+-- representation of the bulk data that flows across a HTTP connection is +-- supported. (see "Network.HTTP.HandleStream".)+-- +-- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission.+-- Normalization such as having the request path be in the expected form and, possibly,+-- introduce a default @Host:@ header if one isn't already present. If you do not +-- want the requests tampered with, but sent as-is, please import and use the+-- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They+-- export the same functions, but leaves construction and any normalization of +-- @Request@s to the user.+--+-- /NOTE:/ This package only supports HTTP; it does not support HTTPS.+-- Attempts to use HTTPS result in an error.+-----------------------------------------------------------------------------+module Network.HTTP +       ( module Network.HTTP.Base+       , module Network.HTTP.Headers++         {- the functionality that the implementation modules, +	    Network.HTTP.HandleStream and Network.HTTP.Stream,+	    exposes:+	 -}+       , simpleHTTP      -- :: Request -> IO (Result Response)+       , simpleHTTP_     -- :: Stream s => s -> Request -> IO (Result Response)+       , sendHTTP        -- :: Stream s => s -> Request -> IO (Result Response)+       , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response)+       , receiveHTTP     -- :: Stream s => s -> IO (Result Request)+       , respondHTTP     -- :: Stream s => s -> Response -> IO ()++       , module Network.TCP+       +       , getRequest      -- :: String -> Request_String+       , postRequest     -- :: String -> Request_String+       , postRequestWithBody -- :: String -> String -> String -> Request_String+       +       , getResponseBody -- :: Requesty ty -> ty+       ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.HTTP.Headers+import Network.HTTP.Base+import qualified Network.HTTP.HandleStream as S+-- old implementation: import Network.HTTP.Stream+import Network.TCP+import Network.Stream ( Result )+import Network.URI    ( parseURI )++import Data.Maybe ( fromMaybe )++{-+ Note: if you switch over/back to using Network.HTTP.Stream here, you'll+ have to wrap the results from 'openStream' as Connections via 'hstreamToConnection'+ prior to delegating to the Network.HTTP.Stream functions.+-}++-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent+-- connection to the HTTP server that @req@ is destined for, followed by transmitting+-- it and gathering up the response as a 'Result'. Prior to sending the request,+-- it is normalized (via 'normalizeRequest'). If you have to mediate the request+-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to+-- using 'Network.Browser' instead.+--+-- Examples:+--+-- > simpleHTTP (getRequest "http://hackage.haskell.org/")+-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/")++simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty))+simpleHTTP r = do+  auth <- getAuth r+  failHTTPS (rqURI r)+  c <- openStream (host auth) (fromMaybe 80 (port auth))+  let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r+  simpleHTTP_ c norm_r+   +-- | Identical to 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+simpleHTTP_ s r = do +  let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r+  S.sendHTTP s norm_r++-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over+-- @hStream@, but does not alter the status of the connection, nor request it to be+-- closed upon receiving the response.+sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+sendHTTP conn rq = do+  let norm_r = normalizeRequest defaultNormalizeRequestOptions rq +  S.sendHTTP conn norm_r++-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but+-- lets you supply an IO @action@ to execute once the request has been successfully+-- transmitted over the connection. Useful when you want to set up tracing of+-- request transmission and its performance.+sendHTTP_notify :: HStream ty+                => HandleStream ty+		-> Request ty+		-> IO ()+		-> IO (Result (Response ty))+sendHTTP_notify conn rq onSendComplete = do+  let norm_r = normalizeRequest defaultNormalizeRequestOptions rq +  S.sendHTTP_notify conn norm_r onSendComplete++-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@+receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty))+receiveHTTP conn = S.receiveHTTP conn++-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over+-- the 'HandleStream' @hStream@. It could be used to implement simple web+-- server interactions, performing the dual role to 'sendHTTP'.+respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()+respondHTTP conn rsp = S.respondHTTP conn rsp++-- | @getRequest urlString@ is convenience constructor for basic GET 'Request's. If+-- @urlString@ isn't a syntactically valid URL, the function raises an error.+getRequest :: String -> Request_String+getRequest urlString = +  case parseURI urlString of+    Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)+    Just u  -> mkRequest GET u++-- | @postRequest urlString@ is convenience constructor for POST 'Request's. If+-- @urlString@ isn\'t a syntactically valid URL, the function raises an error.+postRequest :: String -> Request_String+postRequest urlString = +  case parseURI urlString of+    Nothing -> error ("postRequest: Not a valid URL - " ++ urlString)+    Just u  -> mkRequest POST u++-- | @postRequestWithBody urlString typ body@ is convenience constructor for+-- POST 'Request's. It constructs a request and sets the body as well as+-- the Content-Type and Content-Length headers. The contents of the body+-- are forced to calculate the value for the Content-Length header.+-- If @urlString@ isn\'t a syntactically valid URL, the function raises+-- an error.+postRequestWithBody :: String -> String -> String -> Request_String+postRequestWithBody urlString typ body = +  case parseURI urlString of+    Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString)+    Just u  -> setRequestBody (mkRequest POST u) (typ, body)++-- | @getResponseBody response@ takes the response of a HTTP requesting action and+-- tries to extricate the body of the 'Response' @response@. If the request action+-- returned an error, an IO exception is raised.+getResponseBody :: Result (Response ty) -> IO ty+getResponseBody (Left err) = fail (show err)+getResponseBody (Right r)  = return (rspBody r)++--+-- * TODO+--     - request pipelining+--     - https upgrade (includes full TLS, i.e. SSL, implementation)+--         - use of Stream classes will pay off+--         - consider C implementation of encryption\/decryption+--     - comm timeouts+--     - MIME & entity stuff (happening in separate module)+--     - support \"*\" uri-request-string for OPTIONS request method+-- +-- +-- * Header notes:+--+--     [@Host@]+--                  Required by HTTP\/1.1, if not supplied as part+--                  of a request a default Host value is extracted+--                  from the request-uri.+-- +--     [@Connection@] +--                  If this header is present in any request or+--                  response, and it's value is "close", then+--                  the current request\/response is the last +--                  to be allowed on that connection.+-- +--     [@Expect@]+--                  Should a request contain a body, an Expect+--                  header will be added to the request.  The added+--                  header has the value \"100-continue\".  After+--                  a 417 \"Expectation Failed\" response the request+--                  is attempted again without this added Expect+--                  header.+--                  +--     [@TransferEncoding,ContentLength,...@]+--                  if request is inconsistent with any of these+--                  header values then you may not receive any response+--                  or will generate an error response (probably 4xx).+--+--+-- * Response code notes+-- Some response codes induce special behaviour:+--+--   [@1xx@]   \"100 Continue\" will cause any unsent request body to be sent.+--             \"101 Upgrade\" will be returned.+--             Other 1xx responses are ignored.+-- +--   [@417@]   The reason for this code is \"Expectation failed\", indicating+--             that the server did not like the Expect \"100-continue\" header+--             added to a request.  Receipt of 417 will induce another+--             request attempt (without Expect header), unless no Expect header+--             had been added (in which case 417 response is returned).
+ Network/HTTP/Auth.hs view
@@ -0,0 +1,216 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Auth+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Representing HTTP Auth values in Haskell.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+-- +-----------------------------------------------------------------------------+module Network.HTTP.Auth+       ( Authority(..)+       , Algorithm(..)+       , Challenge(..)+       , Qop(..)++       , headerToChallenge -- :: URI -> Header -> Maybe Challenge+       , withAuthority     -- :: Authority -> Request ty -> String+       ) where++import Network.URI+import Network.HTTP.Base+import Network.HTTP.Utils+import Network.HTTP.Headers ( Header(..) )+import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str))+import qualified Network.HTTP.Base64 as Base64 (encode)+import Text.ParserCombinators.Parsec+   ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 )++import Data.Char+import Data.Maybe+import Data.Word ( Word8 )++-- | @Authority@ specifies the HTTP Authentication method to use for+-- a given domain/realm; @Basic@ or @Digest@.+data Authority + = AuthBasic { auRealm    :: String+             , auUsername :: String+             , auPassword :: String+             , auSite     :: URI+             }+ | AuthDigest{ auRealm     :: String+             , auUsername  :: String+             , auPassword  :: String+             , auNonce     :: String+             , auAlgorithm :: Maybe Algorithm+             , auDomain    :: [URI]+             , auOpaque    :: Maybe String+             , auQop       :: [Qop]+             }+++data Challenge + = ChalBasic  { chRealm   :: String }+ | ChalDigest { chRealm   :: String+              , chDomain  :: [URI]+              , chNonce   :: String+              , chOpaque  :: Maybe String+              , chStale   :: Bool+              , chAlgorithm ::Maybe Algorithm+              , chQop     :: [Qop]+              }++-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@.+data Algorithm = AlgMD5 | AlgMD5sess+    deriving(Eq)++instance Show Algorithm where+    show AlgMD5 = "md5"+    show AlgMD5sess = "md5-sess"++-- | +data Qop = QopAuth | QopAuthInt+    deriving(Eq,Show)++-- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority',+-- in the context of the given request.+-- +-- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String+withAuthority :: Authority -> Request ty -> String+withAuthority a rq = case a of+        AuthBasic{}  -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)+        AuthDigest{} ->+            "Digest " +++	     concat [ "username="  ++ quo (auUsername a)+	            , ",realm="    ++ quo (auRealm a)+		    , ",nonce="    ++ quo (auNonce a)+		    , ",uri="      ++ quo digesturi+		    , ",response=" ++ quo rspdigest+                       -- plus optional stuff:+		    , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))+		    , fromMaybe "" (fmap (\ o   -> ",opaque=" ++ quo o) (auOpaque a))+		    , if null (auQop a) then "" else ",qop=auth"+		    ]+    where+        quo s = '"':s ++ "\""++        rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))++        a1, a2 :: String+        a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a+        +        {-+        If the "qop" directive's value is "auth" or is unspecified, then A2+        is:+           A2  = Method ":" digest-uri-value+        If the "qop" value is "auth-int", then A2 is:+           A2  = Method ":" digest-uri-value ":" H(entity-body)+        -}+        a2 = show (rqMethod rq) ++ ":" ++ digesturi++        digesturi = show (rqURI rq)+        noncevalue = auNonce a++type Octet = Word8++-- FIXME: these probably only work right for latin-1 strings+stringToOctets :: String -> [Octet]+stringToOctets = map (fromIntegral . fromEnum)++base64encode :: String -> String+base64encode = Base64.encode . stringToOctets++md5 :: String -> String+md5 = MD5.md5s . MD5.Str++kd :: String -> String -> String+kd a b = md5 (a ++ ":" ++ b)+++++-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- @www_auth@  into a 'Challenge' value.+headerToChallenge :: URI -> Header -> Maybe Challenge+headerToChallenge baseURI (Header _ str) =+    case parse challenge "" str of+        Left{} -> Nothing+        Right (name,props) -> case name of+            "basic"  -> mkBasic props+            "digest" -> mkDigest props+            _        -> Nothing+    where+        challenge :: Parser (String,[(String,String)])+        challenge =+            do { nme <- word+               ; spaces+               ; pps <- cprops+               ; return (map toLower nme,pps)+               }++        cprops = sepBy1 cprop comma++        comma = do { spaces ; _ <- char ',' ; spaces }++        cprop =+            do { nm <- word+               ; _ <- char '='+               ; val <- quotedstring+               ; return (map toLower nm,val)+               }++        mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge++        mkBasic params = fmap ChalBasic (lookup "realm" params)++        mkDigest params =+            -- with Maybe monad+            do { r <- lookup "realm" params+               ; n <- lookup "nonce" params+               ; return $ +                    ChalDigest { chRealm  = r+                               , chDomain = (annotateURIs +                                            $ map parseURI+                                            $ words +                                            $ fromMaybe [] +                                            $ lookup "domain" params)+                               , chNonce  = n+                               , chOpaque = lookup "opaque" params+                               , chStale  = "true" == (map toLower+                                           $ fromMaybe "" (lookup "stale" params))+                               , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params)+                               , chQop    = readQop (fromMaybe "" $ lookup "qop" params)+                               }+               }++        annotateURIs :: [Maybe URI] -> [URI]+        annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes++        -- Change These:+        readQop :: String -> [Qop]+        readQop = catMaybes . (map strToQop) . (splitBy ',')++        strToQop qs = case map toLower (trim qs) of+            "auth"     -> Just QopAuth+            "auth-int" -> Just QopAuthInt+            _          -> Nothing++        readAlgorithm astr = case map toLower (trim astr) of+            "md5"      -> Just AlgMD5+            "md5-sess" -> Just AlgMD5sess+            _          -> Nothing++word, quotedstring :: Parser String+quotedstring =+    do { _ <- char '"'  -- "+       ; str <- many (satisfy $ not . (=='"'))+       ; _ <- char '"'+       ; return str+       }++word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
+ Network/HTTP/Base.hs view
@@ -0,0 +1,895 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Base+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Definitions of @Request@ and @Response@ types along with functions+-- for normalizing them. It is assumed to be an internal module; user+-- code should, if possible, import @Network.HTTP@ to access the functionality+-- that this module provides.+--+-- Additionally, the module exports internal functions for working with URLs,+-- and for handling the processing of requests and responses coming back.+--+-----------------------------------------------------------------------------+module Network.HTTP.Base+       (+          -- ** Constants+         httpVersion                 -- :: String++          -- ** HTTP+       , Request(..)+       , Response(..)+       , RequestMethod(..)+       +       , Request_String+       , Response_String+       , HTTPRequest+       , HTTPResponse+       +          -- ** URL Encoding+       , urlEncode+       , urlDecode+       , urlEncodeVars++          -- ** URI authority parsing+       , URIAuthority(..)+       , parseURIAuthority+       +          -- internal+       , uriToAuthorityString   -- :: URI     -> String+       , uriAuthToString        -- :: URIAuth -> String+       , uriAuthPort            -- :: Maybe URI -> URIAuth -> Int+       , reqURIAuth             -- :: Request ty -> URIAuth++       , parseResponseHead      -- :: [String] -> Result ResponseData+       , parseRequestHead       -- :: [String] -> Result RequestData++       , ResponseNextStep(..)+       , matchResponse+       , ResponseData+       , ResponseCode+       , RequestData+       +       , NormalizeRequestOptions(..) +       , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty+       , RequestNormalizer++       , normalizeRequest   -- :: NormalizeRequestOptions ty -> Request ty -> Request ty++       , splitRequestURI++       , getAuth+       , normalizeRequestURI+       , normalizeHostHeader+       , findConnClose++         -- internal export (for the use by Network.HTTP.{Stream,ByteStream} )+       , linearTransfer+       , hopefulTransfer+       , chunkedTransfer+       , uglyDeathTransfer+       , readTillEmpty1+       , readTillEmpty2+       +       , defaultGETRequest+       , defaultGETRequest_+       , mkRequest+       , setRequestBody++       , defaultUserAgent+       , httpPackageVersion+       , libUA  {- backwards compatibility, will disappear..soon -}+       +       , catchIO+       , catchIO_+       , responseParseError+       +       , getRequestVersion+       , getResponseVersion+       , setRequestVersion+       , setResponseVersion++       , failHTTPS+       +       ) where++import Network.URI+   ( URI(uriAuthority, uriPath, uriScheme)+   , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)+   , parseURIReference+   )++import Control.Monad ( guard )+import Control.Monad.Error ()+import Data.Char     ( digitToInt, intToDigit, toLower, isDigit,+                       isAscii, isAlphaNum )+import Data.List     ( partition, find )+import Data.Maybe    ( listToMaybe, fromMaybe )+import Numeric       ( readHex )++import Network.Stream+import Network.BufferType ( BufferOp(..), BufferType(..) )+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim, crlf, sp, readsOne )++import Text.Read.Lex (readDecP)+import Text.ParserCombinators.ReadP+   ( ReadP, readP_to_S, char, (<++), look, munch )++import Control.Exception as Exception (IOException)++import qualified Paths_cabal_install_bundle as Self (version)+import Data.Version (showVersion)++-----------------------------------------------------------------+------------------ URI Authority parsing ------------------------+-----------------------------------------------------------------++data URIAuthority = URIAuthority { user :: Maybe String, +				   password :: Maybe String,+				   host :: String,+				   port :: Maybe Int+				 } deriving (Eq,Show)++-- | Parse the authority part of a URL.+--+-- > RFC 1732, section 3.1:+-- >+-- >       //<user>:<password>@<host>:<port>/<url-path>+-- >  Some or all of the parts "<user>:<password>@", ":<password>",+-- >  ":<port>", and "/<url-path>" may be excluded.+parseURIAuthority :: String -> Maybe URIAuthority+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuthority+pURIAuthority = do+		(u,pw) <- (pUserInfo `before` char '@') +			  <++ return (Nothing, Nothing)+		h <- munch (/=':')+		p <- orNothing (char ':' >> readDecP)+		look >>= guard . null +		return URIAuthority{ user=u, password=pw, host=h, port=p }++pUserInfo :: ReadP (Maybe String, Maybe String)+pUserInfo = do+	    u <- orNothing (munch (`notElem` ":@"))+	    p <- orNothing (char ':' >> munch (/='@'))+	    return (u,p)++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++orNothing :: ReadP a -> ReadP (Maybe a)+orNothing p = fmap Just p <++ return Nothing++-- This function duplicates old Network.URI.authority behaviour.+uriToAuthorityString :: URI -> String+uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)++uriAuthToString :: URIAuth -> String+uriAuthToString ua = +  concat [ uriUserInfo ua +         , uriRegName ua+	 , uriPort ua+	 ]++uriAuthPort :: Maybe URI -> URIAuth -> Int+uriAuthPort mbURI u = +  case uriPort u of+    (':':s) -> readsOne id (default_port mbURI) s+    _       -> default_port mbURI+ where+  default_port Nothing = default_http+  default_port (Just url) = +    case map toLower $ uriScheme url of+      "http:" -> default_http+      "https:" -> default_https+        -- todo: refine+      _ -> default_http++  default_http  = 80+  default_https = 443++failHTTPS :: Monad m => URI -> m ()+failHTTPS uri+  | map toLower (uriScheme uri) == "https:" = fail "https not supported"+  | otherwise = return ()++-- Fish out the authority from a possibly normalized Request, i.e.,+-- the information may either be in the request's URI or inside+-- the Host: header.+reqURIAuth :: Request ty -> URIAuth+reqURIAuth req = +  case uriAuthority (rqURI req) of+    Just ua -> ua+    _ -> case lookupHeader HdrHost (rqHeaders req) of+           Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)+	   Just h  -> +	      case toHostPort h of+	        (ht,p) -> URIAuth { uriUserInfo = ""+	                          , uriRegName  = ht+			          , uriPort     = p+			          }+  where+    -- Note: just in case you're wondering..the convention is to include the ':'+    -- in the port part..+   toHostPort h = break (==':') h++-----------------------------------------------------------------+------------------ HTTP Messages --------------------------------+-----------------------------------------------------------------+++-- Protocol version+httpVersion :: String+httpVersion = "HTTP/1.1"+++-- | The HTTP request method, to be used in the 'Request' object.+-- We are missing a few of the stranger methods, but these are+-- not really necessary until we add full TLS.+data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String+    deriving(Eq)++instance Show RequestMethod where+  show x = +    case x of+      HEAD     -> "HEAD"+      PUT      -> "PUT"+      GET      -> "GET"+      POST     -> "POST"+      DELETE   -> "DELETE"+      OPTIONS  -> "OPTIONS"+      TRACE    -> "TRACE"+      CONNECT  -> "CONNECT"+      Custom c -> c++rqMethodMap :: [(String, RequestMethod)]+rqMethodMap = [("HEAD",    HEAD),+	       ("PUT",     PUT),+	       ("GET",     GET),+	       ("POST",    POST),+               ("DELETE",  DELETE),+	       ("OPTIONS", OPTIONS),+	       ("TRACE",   TRACE),+	       ("CONNECT", CONNECT)]++-- +-- for backwards-ish compatibility; suggest+-- migrating to new Req/Resp by adding type param.+-- +type Request_String  = Request String+type Response_String = Response String++-- Hmm..I really want to use these for the record+-- type, but it will upset codebases wanting to+-- migrate (and live with using pre-HTTPbis versions.)+type HTTPRequest a  = Request  a+type HTTPResponse a = Response a++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request a =+     Request { rqURI       :: URI   -- ^ might need changing in future+                                    --  1) to support '*' uri in OPTIONS request+                                    --  2) transparent support for both relative+                                    --     & absolute uris, although this should+                                    --     already work (leave scheme & host parts empty).+             , rqMethod    :: RequestMethod+             , rqHeaders   :: [Header]+             , rqBody      :: a+             }++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show (Request a) where+    show req@(Request u m h _) =+        show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf+        ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf+        where+	    ver = fromMaybe httpVersion (getRequestVersion req)+            alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' +                        then u { uriPath = '/' : uriPath u } +                        else u++instance HasHeaders (Request a) where+    getHeaders = rqHeaders+    setHeaders rq hdrs = rq { rqHeaders=hdrs }++-- | For easy pattern matching, HTTP response codes @xyz@ are+-- represented as @(x,y,z)@.+type ResponseCode  = (Int,Int,Int)++-- | @ResponseData@ contains the head of a response payload;+-- HTTP response code, accompanying text description + header+-- fields.+type ResponseData  = (ResponseCode,String,[Header])++-- | @RequestData@ contains the head of a HTTP request; method,+-- its URL along with the auxillary/supporting header data.+type RequestData   = (RequestMethod,URI,[Header])++-- | An HTTP Response.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output, additionally the output will+-- show an HTTP version of 1.1 instead of the actual version returned+-- by a server.+data Response a =+    Response { rspCode     :: ResponseCode+             , rspReason   :: String+             , rspHeaders  :: [Header]+             , rspBody     :: a+             }+                   +-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1+instance Show (Response a) where+    show rsp@(Response (a,b,c) reason headers _) =+        ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf+        ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf+     where+      ver = fromMaybe httpVersion (getResponseVersion rsp)++instance HasHeaders (Response a) where+    getHeaders = rspHeaders+    setHeaders rsp hdrs = rsp { rspHeaders=hdrs }+++------------------------------------------------------------------+------------------ Request Building ------------------------------+------------------------------------------------------------------++-- | Deprecated. Use 'defaultUserAgent'+libUA :: String+libUA = "hs-HTTP-4000.0.9"+{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-}++-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@+-- where @$version@ is the version of this HTTP package.+--+defaultUserAgent :: String+defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion++-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This+-- may be useful to include in a user agent string so that you can determine+-- from server logs what version of this package HTTP clients are using.+-- This can be useful for tracking down HTTP compatibility quirks.+--+httpPackageVersion :: String+httpPackageVersion = showVersion Self.version++defaultGETRequest :: URI -> Request_String+defaultGETRequest uri = defaultGETRequest_ uri++defaultGETRequest_ :: BufferType a => URI -> Request a+defaultGETRequest_ uri = mkRequest GET uri ++-- | 'mkRequest method uri' constructs a well formed+-- request for the given HTTP method and URI. It does not+-- normalize the URI for the request _nor_ add the required +-- Host: header. That is done either explicitly by the user+-- or when requests are normalized prior to transmission.+mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty+mkRequest meth uri = req+ where+  req = +    Request { rqURI      = uri+            , rqBody     = empty+            , rqHeaders  = [ Header HdrContentLength "0"+                           , Header HdrUserAgent     defaultUserAgent+                           ]+            , rqMethod   = meth+            }++  empty = buf_empty (toBufOps req)++-- set rqBody, Content-Type and Content-Length headers.+setRequestBody :: Request_String -> (String, String) -> Request_String+setRequestBody req (typ, body) = req' { rqBody=body }+  where+    req' = replaceHeader HdrContentType typ .+           replaceHeader HdrContentLength (show $ length body) $+           req++{-+    -- stub out the user info.+  updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)++  withHost = +    case uriToAuthorityString uri{uriAuthority=updAuth} of+      "" -> id+      h  -> ((Header HdrHost h):)++  uri_req +   | forProxy  = uri+   | otherwise = snd (splitRequestURI uri)+-}+++toBufOps :: BufferType a => Request a -> BufferOp a+toBufOps _ = bufferOps++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++-- Parsing a request+parseRequestHead :: [String] -> Result RequestData+parseRequestHead         [] = Left ErrorClosed+parseRequestHead (com:hdrs) = do+  (version,rqm,uri) <- requestCommand com (words com)+  hdrs'              <- parseHeaders hdrs+  return (rqm,uri,withVer version hdrs')+ where+  withVer [] hs = hs+  withVer (h:_) hs = withVersion h hs++  requestCommand l _yes@(rqm:uri:version) =+    case (parseURIReference uri, lookup rqm rqMethodMap) of+     (Just u, Just r) -> return (version,r,u)+     (Just u, Nothing) -> return (version,Custom rqm,u)+     _                -> parse_err l+  requestCommand l _+   | null l    = failWith ErrorClosed+   | otherwise = parse_err l++  parse_err l = responseParseError "parseRequestHead"+                   ("Request command line parse failure: " ++ l)++-- Parsing a response+parseResponseHead :: [String] -> Result ResponseData+parseResponseHead []         = failWith ErrorClosed+parseResponseHead (sts:hdrs) = do+  (version,code,reason)  <- responseStatus sts (words sts)+  hdrs'                  <- parseHeaders hdrs+  return (code,reason, withVersion version hdrs')+ where+  responseStatus _l _yes@(version:code:reason) =+    return (version,match code,concatMap (++" ") reason)+  responseStatus l _no +    | null l    = failWith ErrorClosed  -- an assumption+    | otherwise = parse_err l++  parse_err l = +    responseParseError +        "parseResponseHead"+        ("Response status line parse failure: " ++ l)++  match [a,b,c] = (digitToInt a,+                   digitToInt b,+                   digitToInt c)+  match _ = (-1,-1,-1)  -- will create appropriate behaviour++-- To avoid changing the @RequestData@ and @ResponseData@ types+-- just for this (and the upstream backwards compat. woes that+-- will result in), encode version info as a custom header.+-- Used by 'parseResponseData' and 'parseRequestData'.+--+-- Note: the Request and Response types do not currently represent+-- the version info explicitly in their record types. You have to use+-- {get,set}{Request,Response}Version for that.+withVersion :: String -> [Header] -> [Header]+withVersion v hs + | v == httpVersion = hs  -- don't bother adding it if the default.+ | otherwise        = (Header (HdrCustom "X-HTTP-Version") v) : hs++-- | @getRequestVersion req@ returns the HTTP protocol version of+-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.+getRequestVersion :: Request a -> Maybe String+getRequestVersion r = getHttpVersion r++-- | @setRequestVersion v req@ returns a new request, identical to+-- @req@, but with its HTTP version set to @v@.+setRequestVersion :: String -> Request a -> Request a+setRequestVersion s r = setHttpVersion r s+++-- | @getResponseVersion rsp@ returns the HTTP protocol version of+-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- assumed.+getResponseVersion :: Response a -> Maybe String+getResponseVersion r = getHttpVersion r++-- | @setResponseVersion v rsp@ returns a new response, identical to+-- @rsp@, but with its HTTP version set to @v@.+setResponseVersion :: String -> Response a -> Response a+setResponseVersion s r = setHttpVersion r s++-- internal functions for accessing HTTP-version info in+-- requests and responses. Not exported as it exposes ho+-- version info is represented internally.++getHttpVersion :: HasHeaders a => a -> Maybe String+getHttpVersion r = +  fmap toVersion      $+   find isHttpVersion $+    getHeaders r+ where+  toVersion (Header _ x) = x++setHttpVersion :: HasHeaders a => a -> String -> a+setHttpVersion r v = +  setHeaders r $+   withVersion v  $+    dropHttpVersion $+     getHeaders r++dropHttpVersion :: [Header] -> [Header]+dropHttpVersion hs = filter (not.isHttpVersion) hs++isHttpVersion :: Header -> Bool+isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True+isHttpVersion _ = False    ++++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data ResponseNextStep+ = Continue+ | Retry+ | Done+ | ExpectEntity+ | DieHorribly String++matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep+matchResponse rqst rsp =+    case rsp of+        (1,0,0) -> Continue+        (1,0,1) -> Done        -- upgrade to TLS+        (1,_,_) -> Continue    -- default+        (2,0,4) -> Done+        (2,0,5) -> Done+        (2,_,_) -> ans+        (3,0,4) -> Done+        (3,0,5) -> Done+        (3,_,_) -> ans+        (4,1,7) -> Retry       -- Expectation failed+        (4,_,_) -> ans+        (5,_,_) -> ans+        (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")+    where+        ans | rqst == HEAD = Done+            | otherwise    = ExpectEntity+        ++        +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+    I had a quick look around but couldn't find any RFC about+    the encoding of data on the query string.  I did find an+    IETF memo, however, so this is how I justify the urlEncode+    and urlDecode methods.++    Doc name: draft-tiwari-appl-wxxx-forms-01.txt  (look on www.ietf.org)++    Reserved chars:  ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+    Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+    URI delims: "<" | ">" | "#" | "%" | <">+    Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+                     <US-ASCII coded character 20 hexadecimal>+    Also unallowed:  any non-us-ascii character++    Escape method: char -> '%' a b  where a, b :: Hex digits+-}++urlDecode :: String -> String+urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b)+                         : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []+++urlEncode :: String -> String+urlEncode     [] = []+urlEncode (ch:t) +  | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t+  | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch))+  | otherwise = escape (fromEnum ch) (urlEncode t)+    where+     escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs)+     +     showH x xs+       | x <= 9    = toEnum (o_0 + x) : xs+       | otherwise = toEnum (o_A + (x-10)) : xs+      where+       o_0 = fromEnum '0'+       o_A = fromEnum 'A'++     eightBs :: [Int]  -> Int -> [Int]+     eightBs acc x+      | x <= 0xff = (x:acc)+      | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256)++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars ((n,v):t) =+    let (same,diff) = partition ((==n) . fst) t+    in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+       ++ urlEncodeRest diff+       where urlEncodeRest [] = []+             urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []++-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@+-- header.+getAuth :: Monad m => Request ty -> m URIAuthority+getAuth r = +   -- ToDo: verify that Network.URI functionality doesn't take care of this (now.)+  case parseURIAuthority auth of+    Just x -> return x +    Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"+ where +  auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r)+  uri  = rqURI r++{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}+normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty+normalizeRequestURI doClose h r = +  (if doClose then replaceHeader HdrConnection "close" else id) $+  insertHeaderIfMissing HdrHost h $+    r { rqURI = (rqURI r){ uriScheme = ""+                         , uriAuthority = Nothing+			 }}++-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options+-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option+data NormalizeRequestOptions ty+ = NormalizeRequestOptions+     { normDoClose   :: Bool+     , normForProxy  :: Bool+     , normUserAgent :: Maybe String+     , normCustoms   :: [RequestNormalizer ty]+     }++-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites+-- a request into some normalized form.+type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty++defaultNormalizeRequestOptions :: NormalizeRequestOptions ty+defaultNormalizeRequestOptions = NormalizeRequestOptions+     { normDoClose   = False+     , normForProxy  = False+     , normUserAgent = Just defaultUserAgent+     , normCustoms   = []+     }++-- | @normalizeRequest opts req@ is the entry point to use to normalize your+-- request prior to transmission (or other use.) Normalization is controlled+-- via the @NormalizeRequestOptions@ record.+normalizeRequest :: NormalizeRequestOptions ty+                 -> Request ty+		 -> Request ty+normalizeRequest opts req = foldr (\ f -> f opts) req normalizers+ where+  --normalizers :: [RequestNormalizer ty]+  normalizers = +     ( normalizeHostURI+     : normalizeConnectionClose+     : normalizeUserAgent +     : normCustoms opts+     )++-- | @normalizeUserAgent ua x req@ augments the request @req@ with +-- a @User-Agent: ua@ header if @req@ doesn't already have a +-- a @User-Agent:@ set.+normalizeUserAgent :: RequestNormalizer ty+normalizeUserAgent opts req = +  case normUserAgent opts of+    Nothing -> req+    Just ua -> +     case findHeader HdrUserAgent req of+       Just u  | u /= defaultUserAgent -> req+       _ -> replaceHeader HdrUserAgent ua req++-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then+-- _replaces_ any an existing @Connection:@ header in @req@.+normalizeConnectionClose :: RequestNormalizer ty+normalizeConnectionClose opts req + | normDoClose opts = replaceHeader HdrConnection "close" req+ | otherwise        = req++-- | @normalizeHostURI forProxy req@ rewrites your request to have it+-- follow the expected formats by the receiving party (proxy or server.)+-- +normalizeHostURI :: RequestNormalizer ty+normalizeHostURI opts req = +  case splitRequestURI uri of+    ("",_uri_abs)+      | forProxy -> +         case findHeader HdrHost req of+	   Nothing -> req -- no host/authority in sight..not much we can do.+	   Just h  -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}+	                           , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri+				   }}+            where +	      hst = case span (/='@') user_hst of+	               (as,'@':bs) -> +		          case span (/=':') as of+			    (_,_:_) -> bs+			    _ -> user_hst+		       _ -> user_hst++	      (user_hst, pNum) = +	         case span isDigit (reverse h) of+		   (ds,':':bs) -> (reverse bs, ':':reverse ds)+		   _ -> (h,"")+      | otherwise -> +         case findHeader HdrHost req of+	   Nothing -> req -- no host/authority in sight..not much we can do...complain?+	   Just{}  -> req+    (h,uri_abs) +      | forProxy  -> insertHeaderIfMissing HdrHost h req +      | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass+ where+   uri0     = rqURI req +     -- stub out the user:pass +   uri      = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)}++   forProxy = normForProxy opts++{- Comments re: above rewriting:+    RFC 2616, section 5.1.2:+     "The most common form of Request-URI is that used to identify a+      resource on an origin server or gateway. In this case the absolute+      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as+      the Request-URI, and the network location of the URI (authority) MUST+      be transmitted in a Host header field." +   We assume that this is the case, so we take the host name from+   the Host header if there is one, otherwise from the request-URI.+   Then we make the request-URI an abs_path and make sure that there+   is a Host header.+-}++splitRequestURI :: URI -> ({-authority-}String, URI)+splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing})++-- Adds a Host header if one is NOT ALREADY PRESENT..+{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}+normalizeHostHeader :: Request ty -> Request ty+normalizeHostHeader rq = +  insertHeaderIfMissing HdrHost+                        (uriToAuthorityString $ rqURI rq)+			rq+                                     +-- Looks for a "Connection" header with the value "close".+-- Returns True when this is found.+findConnClose :: [Header] -> Bool+findConnClose hdrs =+  maybe False+        (\ x -> map toLower (trim x) == "close")+	(lookupHeader HdrConnection hdrs)++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))+linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n)++-- | Used when nothing about data is known,+--   Unfortunately waiting for a socket closure+--   causes bad behaviour.  Here we just+--   take data once and give up the rest.+hopefulTransfer :: BufferOp a+                -> IO (Result a)+		-> [a]+		-> IO (Result ([Header],a))+hopefulTransfer bufOps readL strs +    = readL >>= +      either (\v -> return $ Left v)+             (\more -> if (buf_isEmpty bufOps more)+                         then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs))+                         else hopefulTransfer bufOps readL (more:strs))++-- | A necessary feature of HTTP\/1.1+--   Also the only transfer variety likely to+--   return any footers.+chunkedTransfer :: BufferOp a+		-> IO (Result a)+                -> (Int -> IO (Result a))+                -> IO (Result ([Header], a))+chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0++chunkedTransferC :: BufferOp a+                 -> IO (Result a)+                 -> (Int -> IO (Result a))+		 -> [a]+		 -> Int+		 -> IO (Result ([Header], a))+chunkedTransferC bufOps readL readBlk acc n = do+  v <- readL+  case v of+    Left e -> return (Left e)+    Right line +     | size == 0 -> +         -- last chunk read; look for trailing headers..+        fmapE (\ strs -> do+	         ftrs <- parseHeaders (map (buf_toStr bufOps) strs)+		   -- insert (computed) Content-Length header.+		 let ftrs' = Header HdrContentLength (show n) : ftrs+                 return (ftrs',buf_concat bufOps (reverse acc)))++	      (readTillEmpty2 bufOps readL [])++     | otherwise -> do+         some <- readBlk size+	 case some of+	   Left e -> return (Left e)+	   Right cdata -> do+	       _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?+	       chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)+     where+      size +       | buf_isEmpty bufOps line = 0+       | otherwise = +	 case readHex (buf_toStr bufOps line) of+          (hx,_):_ -> hx+          _        -> 0++-- | Maybe in the future we will have a sensible thing+--   to do here, at that time we might want to change+--   the name.+uglyDeathTransfer :: String -> IO (Result ([Header],a))+uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding")++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: BufferOp a+	       -> IO (Result a)+               -> IO (Result [a])+readTillEmpty1 bufOps readL =+  readL >>=+    either (return . Left)+           (\ s -> +	       if buf_isLineTerm bufOps s+                then readTillEmpty1 bufOps readL+                else readTillEmpty2 bufOps readL [s])++-- | Read lines until an empty line (CRLF),+--   also accepts a connection close as end of+--   input, which is not an HTTP\/1.1 compliant+--   thing to do - so probably indicates an+--   error condition.+readTillEmpty2 :: BufferOp a+	       -> IO (Result a)+	       -> [a]+	       -> IO (Result [a])+readTillEmpty2 bufOps readL list =+    readL >>=+      either (return . Left)+             (\ s ->+	        if buf_isLineTerm bufOps s || buf_isEmpty bufOps s+                 then return (Right $ reverse (s:list))+                 else readTillEmpty2 bufOps readL (s:list))++--+-- Misc+--++-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific+-- tweaks better go here.+catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO a h = Prelude.catch a h++catchIO_ :: IO a -> IO a -> IO a+catchIO_ a h = Prelude.catch a (const h)++responseParseError :: String -> String -> Result a+responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))
+ Network/HTTP/Base64.hs view
@@ -0,0 +1,282 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Binary.Base64+-- Copyright   :  (c) Dominic Steinitz 2005, Warrick Gray 2002+-- License     :  BSD-style (see the file ReadMe.tex)+--+-- Maintainer  :  dominic.steinitz@blueyonder.co.uk+-- Stability   :  experimental+-- Portability :  portable+--+-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Network.HTTP.Base64+   ( encode+   , decode+   , chop72+   , Octet+   ) where++{------------------------------------------------------------------------+This is what RFC2045 had to say:++6.8.  Base64 Content-Transfer-Encoding++   The Base64 Content-Transfer-Encoding is designed to represent+   arbitrary sequences of octets in a form that need not be humanly+   readable.  The encoding and decoding algorithms are simple, but the+   encoded data are consistently only about 33 percent larger than the+   unencoded data.  This encoding is virtually identical to the one used+   in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.++   A 65-character subset of US-ASCII is used, enabling 6 bits to be+   represented per printable character. (The extra 65th character, "=",+   is used to signify a special processing function.)++   NOTE:  This subset has the important property that it is represented+   identically in all versions of ISO 646, including US-ASCII, and all+   characters in the subset are also represented identically in all+   versions of EBCDIC. Other popular encodings, such as the encoding+   used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and+   the base85 encoding specified as part of Level 2 PostScript, do not+   share these properties, and thus do not fulfill the portability+   requirements a binary transport encoding for mail must meet.++   The encoding process represents 24-bit groups of input bits as output+   strings of 4 encoded characters.  Proceeding from left to right, a+   24-bit input group is formed by concatenating 3 8bit input groups.+   These 24 bits are then treated as 4 concatenated 6-bit groups, each+   of which is translated into a single digit in the base64 alphabet.+   When encoding a bit stream via the base64 encoding, the bit stream+   must be presumed to be ordered with the most-significant-bit first.+   That is, the first bit in the stream will be the high-order bit in+   the first 8bit byte, and the eighth bit will be the low-order bit in+   the first 8bit byte, and so on.++   Each 6-bit group is used as an index into an array of 64 printable+   characters.  The character referenced by the index is placed in the+   output string.  These characters, identified in Table 1, below, are+   selected so as to be universally representable, and the set excludes+   characters with particular significance to SMTP (e.g., ".", CR, LF)+   and to the multipart boundary delimiters defined in RFC 2046 (e.g.,+   "-").++++                    Table 1: The Base64 Alphabet++     Value Encoding  Value Encoding  Value Encoding  Value Encoding+         0 A            17 R            34 i            51 z+         1 B            18 S            35 j            52 0+         2 C            19 T            36 k            53 1+         3 D            20 U            37 l            54 2+         4 E            21 V            38 m            55 3+         5 F            22 W            39 n            56 4+         6 G            23 X            40 o            57 5+         7 H            24 Y            41 p            58 6+         8 I            25 Z            42 q            59 7+         9 J            26 a            43 r            60 8+        10 K            27 b            44 s            61 9+        11 L            28 c            45 t            62 ++        12 M            29 d            46 u            63 /+        13 N            30 e            47 v+        14 O            31 f            48 w         (pad) =+        15 P            32 g            49 x+        16 Q            33 h            50 y++   The encoded output stream must be represented in lines of no more+   than 76 characters each.  All line breaks or other characters not+   found in Table 1 must be ignored by decoding software.  In base64+   data, characters other than those in Table 1, line breaks, and other+   white space probably indicate a transmission error, about which a+   warning message or even a message rejection might be appropriate+   under some circumstances.++   Special processing is performed if fewer than 24 bits are available+   at the end of the data being encoded.  A full encoding quantum is+   always completed at the end of a body.  When fewer than 24 input bits+   are available in an input group, zero bits are added (on the right)+   to form an integral number of 6-bit groups.  Padding at the end of+   the data is performed using the "=" character.  Since all base64+   input is an integral number of octets, only the following cases can+   arise: (1) the final quantum of encoding input is an integral+   multiple of 24 bits; here, the final unit of encoded output will be+   an integral multiple of 4 characters with no "=" padding, (2) the+   final quantum of encoding input is exactly 8 bits; here, the final+   unit of encoded output will be two characters followed by two "="+   padding characters, or (3) the final quantum of encoding input is+   exactly 16 bits; here, the final unit of encoded output will be three+   characters followed by one "=" padding character.++   Because it is used only for padding at the end of the data, the+   occurrence of any "=" characters may be taken as evidence that the+   end of the data has been reached (without truncation in transit).  No+   such assurance is possible, however, when the number of octets+   transmitted was a multiple of three and no "=" characters are+   present.++   Any characters outside of the base64 alphabet are to be ignored in+   base64-encoded data.++   Care must be taken to use the proper octets for line breaks if base64+   encoding is applied directly to text material that has not been+   converted to canonical form.  In particular, text line breaks must be+   converted into CRLF sequences prior to base64 encoding.  The+   important thing to note is that this may be done directly by the+   encoder rather than in a prior canonicalization step in some+   implementations.++   NOTE: There is no need to worry about quoting potential boundary+   delimiters within base64-encoded bodies within multipart entities+   because no hyphen characters are used in the base64 encoding.++----------------------------------------------------------------------------}++{-++The following properties should hold:++  decode . encode = id+  decode . chop72 . encode = id++I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,+the second variation corresponds better with the RFC above, but outside of+MIME applications might be undesireable.+++But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only +     8 significant bits, which is more than enough for US-ASCII.  +-}+++import Data.Array (Array, array, (!))+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Char (chr, ord)+import Data.Word (Word8)++type Octet = Word8++encodeArray :: Array Int Char+encodeArray = array (0,64) +          [ (0,'A'),  (1,'B'),  (2,'C'),  (3,'D'),  (4,'E'),  (5,'F')                    +          , (6,'G'),  (7,'H'),  (8,'I'),  (9,'J'),  (10,'K'), (11,'L')                    +          , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')+          , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')+          , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')+          , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')+          , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')+          , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')+          , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')+          , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')+          , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]+++-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)+-- clearly the upmost/leftmost 8 bits of the answer are 0.+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.+-- 0 represents a 4 :(+int4_char3 :: [Int] -> [Char]+int4_char3 (a:b:c:d:t) = +    let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)+    in (chr (n `shiftR` 16 .&. 0xff))+     : (chr (n `shiftR` 8 .&. 0xff))+     : (chr (n .&. 0xff)) : int4_char3 t++int4_char3 [a,b,c] =+    let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)+    in [ (chr (n `shiftR` 16 .&. 0xff))+       , (chr (n `shiftR` 8 .&. 0xff)) ]++int4_char3 [a,b] = +    let n = (a `shiftL` 18 .|. b `shiftL` 12)+    in [ (chr (n `shiftR` 16 .&. 0xff)) ]++int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints."++int4_char3 [] = []+++++-- Convert triplets of characters to+-- 4 base64 integers.  The last entries+-- in the list may not produce 4 integers,+-- a trailing 2 character group gives 3 integers,+-- while a trailing single character gives 2 integers.+char3_int4 :: [Char] -> [Int]+char3_int4 (a:b:c:t) +    = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)+      in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6  .&. 0x3f) : (n .&. 0x3f) : char3_int4 t++char3_int4 [a,b]+    = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)+      in [ (n `shiftR` 18 .&. 0x3f)+         , (n `shiftR` 12 .&. 0x3f)+         , (n `shiftR` 6  .&. 0x3f) ]+    +char3_int4 [a]+    = let n = (ord a `shiftL` 16)+      in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]++char3_int4 [] = []+++-- Retrieve base64 char, given an array index integer in the range [0..63]+enc1 :: Int -> Char+enc1 ch = encodeArray!ch+++-- | Cut up a string into 72 char lines, each line terminated by CRLF.++chop72 :: String -> String+chop72 str =  let (bgn,end) = splitAt 70 str+              in if null end then bgn else "\r\n" ++ chop72 end+++-- Pads a base64 code to a multiple of 4 characters, using the special+-- '=' character.+quadruplets :: [Char] -> [Char]+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t+quadruplets [a,b,c]     = [a,b,c,'=']      -- 16bit tail unit+quadruplets [a,b]       = [a,b,'=','=']    -- 8bit tail unit+quadruplets [_]         = error "Network.HTTP.Base64.quadruplets: impossible number of characters."+quadruplets []          = []               -- 24bit tail unit+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++dcd :: String -> [Int]+dcd [] = []+dcd (h:t)+    | h <= 'Z' && h >= 'A'  =  ord h - ord 'A'      : dcd t+    | h >= '0' && h <= '9'  =  ord h - ord '0' + 52 : dcd t+    | h >= 'a' && h <= 'z'  =  ord h - ord 'a' + 26 : dcd t+    | h == '+'  = 62 : dcd t+    | h == '/'  = 63 : dcd t+    | h == '='  = []  -- terminate data stream+    | otherwise = dcd t+++-- Principal encoding and decoding functions.++encode :: [Octet] -> String+encode = enc . char3_int4 . (map (chr .fromIntegral))++{-+prop_base64 os =+   os == (f . g . h) os+      where types = (os :: [Word8])+            f = map (fromIntegral. ord)+            g = decode . encode+            h = map (chr . fromIntegral)+-}++decode :: String -> [Octet]+decode = (map (fromIntegral . ord)) . int4_char3 . dcd
+ Network/HTTP/Cookie.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Cookie+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- This module provides the data types and functions for working with HTTP cookies.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+-- +-----------------------------------------------------------------------------+module Network.HTTP.Cookie+       ( Cookie(..)+       , cookieMatch          -- :: (String,String) -> Cookie -> Bool++          -- functions for translating cookies and headers.+       , cookiesToHeader      -- :: [Cookie] -> Header+       , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie])+       ) where++import Network.HTTP.Headers++import Data.Char+import Data.List+import Data.Maybe++import Text.ParserCombinators.Parsec+   ( Parser, char, many, many1, satisfy, parse, option, try+   , (<|>), sepBy1+   )++------------------------------------------------------------------+----------------------- Cookie Stuff -----------------------------+------------------------------------------------------------------++-- | @Cookie@ is the Haskell representation of HTTP cookie values.+-- See its relevant specs for authoritative details.+data Cookie + = MkCookie +    { ckDomain  :: String+    , ckName    :: String+    , ckValue   :: String+    , ckPath    :: Maybe String+    , ckComment :: Maybe String+    , ckVersion :: Maybe String+    }+    deriving(Show,Read)++instance Eq Cookie where+    a == b  =  ckDomain a == ckDomain b +            && ckName a == ckName b +            && ckPath a == ckPath b++-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.+cookiesToHeader :: [Cookie] -> Header+cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs)++-- | Turn a list of cookies into a key=value pair list, separated by+-- semicolons.+mkCookieHeaderValue :: [Cookie] -> String+mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1+  where+    mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c++-- | @cookieMatch (domain,path) ck@ performs the standard cookie+-- match wrt the given domain and path. +cookieMatch :: (String, String) -> Cookie -> Bool+cookieMatch (dom,path) ck =+ ckDomain ck `isSuffixOf` dom &&+ case ckPath ck of+   Nothing -> True+   Just p  -> p `isPrefixOf` path+++-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie])+processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs++-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])+headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = +    case parse cookies "" val of+        Left{}  -> (val:accErr, accCookie)+        Right x -> (accErr, x ++ accCookie)+  where+   cookies :: Parser [Cookie]+   cookies = sepBy1 cookie (char ',')++   cookie :: Parser Cookie+   cookie =+       do name <- word+          _    <- spaces_l+          _    <- char '='+          _    <- spaces_l+          val1 <- cvalue+          args <- cdetail+          return $ mkCookie name val1 args++   cvalue :: Parser String+   +   spaces_l = many (satisfy isSpace)++   cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""+   +   -- all keys in the result list MUST be in lower case+   cdetail :: Parser [(String,String)]+   cdetail = many $+       try (do _  <- spaces_l+               _  <- char ';'+               _  <- spaces_l+               s1 <- word+               _  <- spaces_l+               s2 <- option "" (char '=' >> spaces_l >> cvalue)+               return (map toLower s1,s2)+           )++   mkCookie :: String -> String -> [(String,String)] -> Cookie+   mkCookie nm cval more = +	  MkCookie { ckName    = nm+                   , ckValue   = cval+                   , ckDomain  = map toLower (fromMaybe dom (lookup "domain" more))+                   , ckPath    = lookup "path" more+                   , ckVersion = lookup "version" more+                   , ckComment = lookup "comment" more+                   }+headerToCookies _ _ acc = acc++      +++word, quotedstring :: Parser String+quotedstring =+    do _   <- char '"'  -- "+       str <- many (satisfy $ not . (=='"'))+       _   <- char '"'+       return str++word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
+ Network/HTTP/HandleStream.hs view
@@ -0,0 +1,246 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.HandleStream+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- A 'HandleStream'-based version of "Network.HTTP" interface.+--+-- For more detailed information about what the individual exports do, please consult+-- the documentation for "Network.HTTP". /Notice/ however that the functions here do+-- not perform any kind of normalization prior to transmission (or receipt); you are+-- responsible for doing any such yourself, or, if you prefer, just switch to using+-- "Network.HTTP" function instead.+-- +-----------------------------------------------------------------------------+module Network.HTTP.HandleStream +       ( simpleHTTP      -- :: Request ty -> IO (Result (Response ty))+       , simpleHTTP_     -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+       , sendHTTP        -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+       , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))+       , receiveHTTP     -- :: HStream ty => HandleStream ty -> IO (Result (Request ty))+       , respondHTTP     -- :: HStream ty => HandleStream ty -> Response ty -> IO ()+       +       , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString)+       ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.BufferType+import Network.Stream ( fmapE, Result )+import Network.StreamDebugger ( debugByteStream )+import Network.TCP (HStream(..), HandleStream )++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim, readsOne )++import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import Control.Monad (when)++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- | @simpleHTTP@ transmits a resource across a non-persistent connection.+simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))+simpleHTTP r = do +  auth <- getAuth r+  failHTTPS (rqURI r)+  c <- openStream (host auth) (fromMaybe 80 (port auth))+  simpleHTTP_ c r++-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs+-- the HTTP operation via the debug file @debugFile@.+simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))+simpleHTTP_debug httpLogFile r = do +  auth <- getAuth r+  failHTTPS (rqURI r)+  c0   <- openStream (host auth) (fromMaybe 80 (port auth))+  c    <- debugByteStream httpLogFile c0+  simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+simpleHTTP_ s r = sendHTTP s r++-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over+-- @hStream@, but does not alter the status of the connection, nor request it to be+-- closed upon receiving the response.+sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+sendHTTP conn rq = sendHTTP_notify conn rq (return ())++-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but+-- lets you supply an IO @action@ to execute once the request has been successfully+-- transmitted over the connection. Useful when you want to set up tracing of+-- request transmission and its performance.+sendHTTP_notify :: HStream ty+                => HandleStream ty+		-> Request ty+		-> IO ()+		-> IO (Result (Response ty))+sendHTTP_notify conn rq onSendComplete = do+  when providedClose $ (closeOnEnd conn True)+  catchIO (sendMain conn rq onSendComplete)+          (\e -> do { close conn; ioError e })+ where+  providedClose = findConnClose (rqHeaders rq)++-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+sendMain :: HStream ty+         => HandleStream ty+	 -> Request ty+	 -> (IO ())+	 -> IO (Result (Response ty))+sendMain conn rqst onSendComplete = do+      --let str = if null (rqBody rqst)+      --              then show rqst+      --              else show (insertHeader HdrExpect "100-continue" rqst)+  writeBlock conn (buf_fromStr bufferOps $ show rqst)+    -- write body immediately, don't wait for 100 CONTINUE+  writeBlock conn (rqBody rqst)+  onSendComplete+  rsp <- getResponseHead conn+  switchResponse conn True False rsp rqst++   -- Hmmm, this could go bad if we keep getting "100 Continue"+   -- responses...  Except this should never happen according+   -- to the RFC.++switchResponse :: HStream ty+               => HandleStream ty+	       -> Bool {- allow retry? -}+               -> Bool {- is body sent? -}+               -> Result ResponseData+               -> Request ty+               -> IO (Result (Response ty))+switchResponse _ _ _ (Left e) _ = return (Left e)+                -- retry on connreset?+                -- if we attempt to use the same socket then there is an excellent+                -- chance that the socket is not in a completely closed state.++switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +   case matchResponse (rqMethod rqst) cd of+     Continue+      | not bdy_sent -> do {- Time to send the body -}+        writeBlock conn (rqBody rqst) >>= either (return . Left)+	   (\ _ -> do+              rsp <- getResponseHead conn+              switchResponse conn allow_retry True rsp rqst)+      | otherwise    -> do {- keep waiting -}+        rsp <- getResponseHead conn+        switchResponse conn allow_retry bdy_sent rsp rqst++     Retry -> do {- Request with "Expect" header failed.+                    Trouble is the request contains Expects+                    other than "100-Continue" -}+        writeBlock conn ((buf_append bufferOps)+		                     (buf_fromStr bufferOps (show rqst))+			             (rqBody rqst))+        rsp <- getResponseHead conn+        switchResponse conn False bdy_sent rsp rqst+                     +     Done -> do+       when (findConnClose hdrs)+            (closeOnEnd conn True)+       return (Right $ Response cd rn hdrs (buf_empty bufferOps))++     DieHorribly str -> do+       close conn+       return (responseParseError "Invalid response:" str)+     ExpectEntity -> do+       r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $+             maybe (maybe (hopefulTransfer bo (readLine conn) [])+	               (\ x -> +		          readsOne (linearTransfer (readBlock conn))+		                   (return$responseParseError "unrecognized content-length value" x)+			  	   x)+		        cl)+	           (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+	                      (uglyDeathTransfer "sendHTTP"))+                   tc+       case r of+         Left{} -> do+	   close conn+	   return r+	 Right (Response _ _ hs _) -> do+	   when (findConnClose hs)+                (closeOnEnd conn True)+	   return r++      where+       tc = lookupHeader HdrTransferEncoding hdrs+       cl = lookupHeader HdrContentLength hdrs+       bo = bufferOps+                    +-- reads and parses headers+getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)+getResponseHead conn = +   fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es))+         (readTillEmpty1 bufferOps (readLine conn))++-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@+receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy))+receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest+  where+    -- reads and parses headers+   getRequestHead :: IO (Result RequestData)+   getRequestHead = do+      fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es))+            (readTillEmpty1 bufferOps (readLine conn))+	+   processRequest (rm,uri,hdrs) =+      fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $+	     maybe +	      (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""+	             (\ x -> readsOne (linearTransfer (readBlock conn))+			              (return$responseParseError "unrecognized Content-Length value" x)+				      x)+				      +		     cl)+  	      (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+	                 (uglyDeathTransfer "receiveHTTP"))+              tc+    where+     -- FIXME : Also handle 100-continue.+     tc = lookupHeader HdrTransferEncoding hdrs+     cl = lookupHeader HdrContentLength hdrs+     bo = bufferOps++-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over+-- the 'HandleStream' @hStream@. It could be used to implement simple web+-- server interactions, performing the dual role to 'sendHTTP'.+respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()+respondHTTP conn rsp = do +  writeBlock conn (buf_fromStr bufferOps $ show rsp)+   -- write body immediately, don't wait for 100 CONTINUE+  writeBlock conn (rspBody rsp)+  return ()++------------------------------------------------------------------------------++headerName :: String -> String+headerName x = map toLower (trim x)++ifChunked :: a -> a -> String -> a+ifChunked a b s = +  case headerName s of+    "chunked" -> a+    _ -> b+
+ Network/HTTP/Headers.hs view
@@ -0,0 +1,306 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Headers+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- This module provides the data types for representing HTTP headers, and+-- operations for looking up header values and working with sequences of+-- header values in 'Request's and 'Response's. To avoid having to provide+-- separate set of operations for doing so, we introduce a type class 'HasHeaders'+-- to facilitate writing such processing using overloading instead.+-- +-----------------------------------------------------------------------------+module Network.HTTP.Headers+   ( HasHeaders(..)     -- type class++   , Header(..)+   , mkHeader           -- :: HeaderName -> String -> Header+   , hdrName            -- :: Header     -> HeaderName+   , hdrValue           -- :: Header     -> String++   , HeaderName(..)++   , insertHeader          -- :: HasHeaders a => HeaderName -> String -> a -> a+   , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a+   , insertHeaders         -- :: HasHeaders a => [Header] -> a -> a+   , retrieveHeaders       -- :: HasHeaders a => HeaderName -> a -> [Header]+   , replaceHeader         -- :: HasHeaders a => HeaderName -> String -> a -> a+   , findHeader            -- :: HasHeaders a => HeaderName -> a -> Maybe String+   , lookupHeader          -- :: HeaderName -> [Header] -> Maybe String++   , parseHeader           -- :: parseHeader :: String -> Result Header+   , parseHeaders          -- :: [String] -> Result [Header]+   +   , headerMap             -- :: [(String, HeaderName)]+   +   , HeaderSetter+   ) where++import Data.Char (toLower)+import Network.Stream (Result, failParse)+import Network.HTTP.Utils ( trim, split, crlf )++-- | The @Header@ data type pairs header names & values.+data Header = Header HeaderName String++hdrName :: Header -> HeaderName+hdrName (Header h _) = h++hdrValue :: Header -> String+hdrValue (Header _ v) = v++-- | Header constructor as a function, hiding above rep.+mkHeader :: HeaderName -> String -> Header+mkHeader = Header++instance Show Header where+    show (Header key value) = shows key (':':' ':value ++ crlf)++-- | HTTP @HeaderName@ type, a Haskell data constructor for each+-- specification-defined header, prefixed with @Hdr@ and CamelCased,+-- (i.e., eliding the @-@ in the process.) Should you require using+-- a custom header, there's the @HdrCustom@ constructor which takes+-- a @String@ argument.+--+-- Encoding HTTP header names differently, as Strings perhaps, is an+-- equally fine choice..no decidedly clear winner, but let's stick+-- with data constructors here.+-- +data HeaderName +    -- Generic Headers --+ = HdrCacheControl+ | HdrConnection+ | HdrDate+ | HdrPragma+ | HdrTransferEncoding        + | HdrUpgrade                + | HdrVia+    -- Request Headers --+ | HdrAccept+ | HdrAcceptCharset+ | HdrAcceptEncoding+ | HdrAcceptLanguage+ | HdrAuthorization+ | HdrCookie+ | HdrExpect+ | HdrFrom+ | HdrHost+ | HdrIfModifiedSince+ | HdrIfMatch+ | HdrIfNoneMatch+ | HdrIfRange+ | HdrIfUnmodifiedSince+ | HdrMaxForwards+ | HdrProxyAuthorization+ | HdrRange+ | HdrReferer+ | HdrUserAgent+    -- Response Headers+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrTE+ | HdrTrailer+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate+    -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified+    -- | MIME entity headers (for sub-parts)+ | HdrContentTransferEncoding+    -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.+    deriving(Eq)++-- | @headerMap@ is a straight assoc list for translating between header names +-- and values.+headerMap :: [ (String,HeaderName) ]+headerMap =+   [ p "Cache-Control"        HdrCacheControl+   , p "Connection"           HdrConnection+   , p "Date"                 HdrDate+   , p "Pragma"               HdrPragma+   , p "Transfer-Encoding"    HdrTransferEncoding+   , p "Upgrade"              HdrUpgrade+   , p "Via"                  HdrVia+   , p "Accept"               HdrAccept+   , p "Accept-Charset"       HdrAcceptCharset+   , p "Accept-Encoding"      HdrAcceptEncoding+   , p "Accept-Language"      HdrAcceptLanguage+   , p "Authorization"        HdrAuthorization+   , p "Cookie"               HdrCookie+   , p "Expect"               HdrExpect+   , p "From"                 HdrFrom+   , p "Host"                 HdrHost+   , p "If-Modified-Since"    HdrIfModifiedSince+   , p "If-Match"             HdrIfMatch+   , p "If-None-Match"        HdrIfNoneMatch+   , p "If-Range"             HdrIfRange+   , p "If-Unmodified-Since"  HdrIfUnmodifiedSince+   , p "Max-Forwards"         HdrMaxForwards+   , p "Proxy-Authorization"  HdrProxyAuthorization+   , p "Range"                HdrRange+   , p "Referer"              HdrReferer+   , p "User-Agent"           HdrUserAgent+   , p "Age"                  HdrAge+   , p "Location"             HdrLocation+   , p "Proxy-Authenticate"   HdrProxyAuthenticate+   , p "Public"               HdrPublic+   , p "Retry-After"          HdrRetryAfter+   , p "Server"               HdrServer+   , p "Set-Cookie"           HdrSetCookie+   , p "TE"                   HdrTE+   , p "Trailer"              HdrTrailer+   , p "Vary"                 HdrVary+   , p "Warning"              HdrWarning+   , p "WWW-Authenticate"     HdrWWWAuthenticate+   , p "Allow"                HdrAllow+   , p "Content-Base"         HdrContentBase+   , p "Content-Encoding"     HdrContentEncoding+   , p "Content-Language"     HdrContentLanguage+   , p "Content-Length"       HdrContentLength+   , p "Content-Location"     HdrContentLocation+   , p "Content-MD5"          HdrContentMD5+   , p "Content-Range"        HdrContentRange+   , p "Content-Type"         HdrContentType+   , p "ETag"                 HdrETag+   , p "Expires"              HdrExpires+   , p "Last-Modified"        HdrLastModified+   , p "Content-Transfer-Encoding" HdrContentTransferEncoding+   ]+ where+  p a b = (a,b)++instance Show HeaderName where+    show (HdrCustom s) = s+    show x = case filter ((==x).snd) headerMap of+                [] -> error "headerMap incomplete"+                (h:_) -> fst h++-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing+-- you to write overloaded header manipulation functions+-- for both 'Request' and 'Response' data types, for instance.+class HasHeaders x where+    getHeaders :: x -> [Header]+    setHeaders :: x -> [Header] -> x++-- Header manipulation functions++type HeaderSetter a = HeaderName -> String -> a -> a++-- | @insertHeader hdr val x@ inserts a header with the given header name+-- and value. Does not check for existing headers with same name, allowing+-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.)+insertHeader :: HasHeaders a => HeaderSetter a+insertHeader name value x = setHeaders x newHeaders+    where+        newHeaders = (Header name value) : getHeaders x++-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous+-- header with name @hdr@ exists in @x@.+insertHeaderIfMissing :: HasHeaders a => HeaderSetter a+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+    where+        newHeaders list@(h@(Header n _): rest)+            | n == name  = list+            | otherwise  = h : newHeaders rest+        newHeaders [] = [Header name value]++-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the+-- value @val@, dropping any existing +replaceHeader :: HasHeaders a => HeaderSetter a+replaceHeader name value h = setHeaders h newHeaders+    where+        newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ]+          +-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing+-- set.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)++-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+    where+        matchname (Header n _) = n == name ++-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first+-- header that matches, if any.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the+-- list @hdrs@.+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader _ [] = Nothing+lookupHeader v (Header n s:t)  +  |  v == n   =  Just s+  | otherwise =  lookupHeader v t++-- | @parseHeader headerNameAndValueString@ tries to unscramble a+-- @header: value@ pairing and returning it as a 'Header'.+parseHeader :: String -> Result Header+parseHeader str =+    case split ':' str of+        Nothing -> failParse ("Unable to parse header: " ++ str)+        Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v)+    where+        fn k = case map snd $ filter (match k . fst) headerMap of+                 [] -> (HdrCustom k)+                 (h:_) -> h++        match :: String -> String -> Bool+        match s1 s2 = map toLower s1 == map toLower s2+    +-- | @parseHeaders hdrs@ takes a sequence of strings holding header+-- information and parses them into a set of headers (preserving their+-- order in the input argument.) Handles header values split up over+-- multiple lines.+parseHeaders :: [String] -> Result [Header]+parseHeaders = catRslts [] . +                 map (parseHeader . clean) . +		     joinExtended ""+   where+        -- Joins consecutive lines where the second line+        -- begins with ' ' or '\t'.+        joinExtended old      [] = [old]+        joinExtended old (h : t)+	  | isLineExtension h    = joinExtended (old ++ ' ' : tail h) t+          | otherwise            = old : joinExtended h t+	+	isLineExtension (x:_) = x == ' ' || x == '\t'+	isLineExtension _ = False++        clean [] = []+        clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+                    | otherwise = h : clean t++        -- tolerant of errors?  should parse+        -- errors here be reported or ignored?+        -- currently ignored.+        catRslts :: [a] -> [Result a] -> Result [a]+        catRslts list (h:t) = +            case h of+                Left _ -> catRslts list t+                Right v -> catRslts (v:list) t+        catRslts list [] = Right $ reverse list
+ Network/HTTP/MD5Aux.hs view
@@ -0,0 +1,342 @@+module Network.HTTP.MD5Aux +   (md5,  md5s,  md5i,+    MD5(..), ABCD(..), +    Zord64, Str(..), BoolList(..), WordList(..)) where++import Data.Char (ord, chr)+import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)+import Data.Word (Word32, Word64)++rotL :: Word32 -> Int -> Word32+rotL x = rotateL x++type Zord64 = Word64++-- ===================== TYPES AND CLASS DEFINTIONS ========================+++type XYZ = (Word32, Word32, Word32)+type Rotation = Int+newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show)+newtype Str = Str String+newtype BoolList = BoolList [Bool]+newtype WordList = WordList ([Word32], Word64)++-- Anything we want to work out the MD5 of must be an instance of class MD5++class MD5 a where+ get_next :: a -> ([Word32], Int, a) -- get the next blocks worth+ --                     \      \   \------ the rest of the input+ --                      \      \--------- the number of bits returned+ --                       \--------------- the bits returned in 32bit words+ len_pad :: Word64 -> a -> a         -- append the padding and length+ finished :: a -> Bool               -- Have we run out of input yet?+++-- Mainly exists because it's fairly easy to do MD5s on input where the+-- length is not a multiple of 8++instance MD5 BoolList where+ get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs)+  where (ys, zs) = splitAt 512 s+ len_pad l (BoolList bs)+  = BoolList (bs ++ [True]+                 ++ replicate (fromIntegral $ (447 - l) .&. 511) False+                 ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])]+             )+  where mangle [] = []+        mangle xs = reverse ys ++ mangle zs+         where (ys, zs) = splitAt 8 xs+ finished (BoolList s) = s == []+++-- The string instance is fairly straightforward++instance MD5 Str where+ get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs)+  where (ys, zs) = splitAt 64 s+ len_pad c64 (Str s) = Str (s ++ padding ++ l)+  where padding = '\128':replicate (fromIntegral zeros) '\000'+        zeros = shiftR ((440 - c64) .&. 511) 3+        l = length_to_chars 8 c64+ finished (Str s) = s == ""+++-- YA instance that is believed will be useful++instance MD5 WordList where+ get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken))+  where (xs, ys) = splitAt 16 ws+        taken = if l > 511 then 512 else l .&. 511+ len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen)+  where beginning = if length ws > 0 then start ++ lastone' else []+        start = init ws+        lastone = last ws+        offset = c64 .&. 31+        lastone' = [if offset > 0 then lastone + theone else lastone]+        theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7))+                        (fromIntegral $ offset .&. (31 - 7))+        nextish = if offset == 0 then [128] else []+        c64' = c64 + (32 - offset)+        num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5)+        blanks = replicate num_blanks 0+        lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1)+        topsize = fromIntegral $ shiftR c64 32+        size = [lowsize, topsize]+        newlen = l .&. (complement 511)+               + if c64 .&. 511 >= 448 then 1024 else 512+ finished (WordList (_, z)) = z == 0+++instance Num ABCD where+ ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)++ (*)         = error "(*){ABCD}: no instance method defined"+ signum      = error "signum{ABCD}: no instance method defined"+ fromInteger = error "fromInteger{ABCD}: no instance method defined"+ abs         = error "abs{ABCD}: no instance method defined"+-- ===================== EXPORTED FUNCTIONS ========================+++-- The simplest function, gives you the MD5 of a string as 4-tuple of+-- 32bit words.++md5 :: (MD5 a) => a -> ABCD+md5 m = md5_main False 0 magic_numbers m+++-- Returns a hex number ala the md5sum program++md5s :: (MD5 a) => a -> String+md5s = abcd_to_string . md5+++-- Returns an integer equivalent to the above hex number++md5i :: (MD5 a) => a -> Integer+md5i = abcd_to_integer . md5+++-- ===================== THE CORE ALGORITHM ========================+++-- Decides what to do. The first argument indicates if padding has been+-- added. The second is the length mod 2^64 so far. Then we have the+-- starting state, the rest of the string and the final state.++md5_main :: (MD5 a) =>+            Bool   -- Have we added padding yet?+         -> Word64 -- The length so far mod 2^64+         -> ABCD   -- The initial state+         -> a      -- The non-processed portion of the message+         -> ABCD   -- The resulting state+md5_main padded ilen abcd m+ = if finished m && padded+   then abcd+   else md5_main padded' (ilen + 512) (abcd + abcd') m''+ where (m16, l, m') = get_next m+       len' = ilen + fromIntegral l+       ((m16', _, m''), padded') = if not padded && l < 512+                                   then (get_next $ len_pad len' m, True)+                                   else ((m16, l, m'), padded)+       abcd' = md5_do_block abcd m16'+++-- md5_do_block processes a 512 bit block by calling md5_round 4 times to+-- apply each round with the correct constants and permutations of the+-- block++md5_do_block :: ABCD     -- Initial state+             -> [Word32] -- The block to be processed - 16 32bit words+             -> ABCD     -- Resulting state+md5_do_block abcd0 w = abcd4+ where (r1, r2, r3, r4) = rounds+       {-+       map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12]+                       -- [(5 * x + 1) `mod` 16 | x <- [0..15]]+       map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2]+                       -- [(3 * x + 5) `mod` 16 | x <- [0..15]]+       map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9]+                       -- [(7 * x) `mod` 16 | x <- [0..15]]+       -}+       perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+        = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12]+       perm5 _ = error "broke at perm5"+       perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+        = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2]+       perm3 _ = error "broke at perm3"+       perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+        = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9]+       perm7 _ = error "broke at perm7"+       abcd1 = md5_round md5_f abcd0        w  r1+       abcd2 = md5_round md5_g abcd1 (perm5 w) r2+       abcd3 = md5_round md5_h abcd2 (perm3 w) r3+       abcd4 = md5_round md5_i abcd3 (perm7 w) r4+++-- md5_round does one of the rounds. It takes an auxiliary function and foldls+-- (md5_inner_function f) to repeatedly apply it to the initial state with the+-- correct constants++md5_round :: (XYZ -> Word32)      -- Auxiliary function (F, G, H or I+                                  -- for those of you with a copy of+                                  -- the prayer book^W^WRFC)+          -> ABCD                 -- Initial state+          -> [Word32]             -- The 16 32bit words of input+          -> [(Rotation, Word32)] -- The list of 16 rotations and+                                  -- additive constants+          -> ABCD                 -- Resulting state+md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns'+ where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns+++-- Apply one of the functions md5_[fghi] and put the new ABCD together++md5_inner_function :: (XYZ -> Word32)    -- Auxiliary function+                   -> ABCD               -- Initial state+                   -> (Rotation, Word32) -- The rotation and additive+                                         -- constant (X[i] + T[j])+                   -> ABCD               -- Resulting state+md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c)+ where mid_a = a + f(b,c,d) + ki+       rot_a = rotL mid_a s+       a' = b + rot_a+++-- The 4 auxiliary functions++md5_f :: XYZ -> Word32+md5_f (x, y, z) = z `xor` (x .&. (y `xor` z))+{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -}++md5_g :: XYZ -> Word32+md5_g (x, y, z) = md5_f (z, x, y)+{- was: (x .&. z) .|. (y .&. (complement z)) -}++md5_h :: XYZ -> Word32+md5_h (x, y, z) = x `xor` y `xor` z++md5_i :: XYZ -> Word32+md5_i (x, y, z) = y `xor` (x .|. (complement z))+++-- The magic numbers from the RFC.++magic_numbers :: ABCD+magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476)+++-- The 4 lists of (rotation, additive constant) tuples, one for each round++rounds :: ([(Rotation, Word32)],+           [(Rotation, Word32)],+           [(Rotation, Word32)],+           [(Rotation, Word32)])+rounds = (r1, r2, r3, r4)+ where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db),+             (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a),+             (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8),+             (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be),+             (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e),+             (s14, 0x49b40821)]+       r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51),+             (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22,  0x2441453),+             (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6),+             (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed),+             (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9),+             (s24, 0x8d2a4c8a)]+       r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122),+             (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9),+             (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6),+             (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34,  0x4881d05),+             (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8),+             (s34, 0xc4ac5665)]+       r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7),+             (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92),+             (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f),+             (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1),+             (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb),+             (s44, 0xeb86d391)]+       s11 = 7+       s12 = 12+       s13 = 17+       s14 = 22+       s21 = 5+       s22 = 9+       s23 = 14+       s24 = 20+       s31 = 4+       s32 = 11+       s33 = 16+       s34 = 23+       s41 = 6+       s42 = 10+       s43 = 15+       s44 = 21+++-- ===================== CONVERSION FUNCTIONS ========================+++-- Turn the 4 32 bit words into a string representing the hex number they+-- represent.++abcd_to_string :: ABCD -> String+abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d]+++-- Split the 32 bit word up, swap the chunks over and convert the numbers+-- to their hex equivalents.++display_32bits_as_hex :: Word32 -> String+display_32bits_as_hex w = swap_pairs cs+ where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7]+       getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)+       swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs+       swap_pairs _ = []++-- Convert to an integer, performing endianness magic as we go++abcd_to_integer :: ABCD -> Integer+abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int)+                                 + rev_num b * 2^(64 :: Int)+                                 + rev_num c * 2^(32 :: Int)+                                 + rev_num d++rev_num :: Word32 -> Integer+rev_num i = toInteger j `mod` (2^(32 :: Int))+ --         NHC's fault ~~~~~~~~~~~~~~~~~~~~~+ where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255))+                 0 [0,8,16,24]++-- Used to convert a 64 byte string to 16 32bit words++string_to_word32s :: String -> [Word32]+string_to_word32s "" = []+string_to_word32s ss = this:string_to_word32s ss'+ where (s, ss') = splitAt 4 ss+       this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s+++-- Used to convert a list of 512 bools to 16 32bit words++bools_to_word32s :: [Bool] -> [Word32]+bools_to_word32s [] = []+bools_to_word32s bs = this:bools_to_word32s rest+ where (bs1, bs1') = splitAt 8 bs+       (bs2, bs2') = splitAt 8 bs1'+       (bs3, bs3') = splitAt 8 bs2'+       (bs4, rest) = splitAt 8 bs3'+       this = boolss_to_word32 [bs1, bs2, bs3, bs4]+       bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0+       boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0+++-- Convert the size into a list of characters used by the len_pad function+-- for strings++length_to_chars :: Int -> Word64 -> String+length_to_chars 0 _ = []+length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8)+         where this = chr $ fromIntegral $ n .&. 255+
+ Network/HTTP/Proxy.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Proxy+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Handling proxy server settings and their resolution.+-- +-----------------------------------------------------------------------------+module Network.HTTP.Proxy+       ( Proxy(..)+       , noProxy     -- :: Proxy+       , fetchProxy  -- :: Bool -> IO Proxy+       , parseProxy  -- :: String -> Maybe Proxy+       ) where++import Control.Monad ( when, mplus, join, liftM2)++import Network.HTTP.Utils ( dropWhileTail, chopAtDelim )+import Network.HTTP.Auth+import Network.URI+   ( URI(..), URIAuth(..), parseAbsoluteURI )+import System.IO ( hPutStrLn, stderr )+import System.Environment++{-+#if !defined(WIN32) && defined(mingw32_HOST_OS)+#define WIN32 1+#endif+-}++#if defined(WIN32)+import System.Win32.Types   ( DWORD, HKEY )+import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx )+import Control.Exception    ( bracket )+import Foreign              ( toBool, Storable(peek, sizeOf), castPtr, alloca )+#endif++-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a+-- proxy should be used for the request (see 'Network.Browser.setProxy')+data Proxy + = NoProxy                 -- ^ Don't use a proxy.+ | Proxy String+         (Maybe Authority) -- ^ Use the proxy given. Should be of the+                           -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host".+                           -- Additionally, an optional 'Authority' for authentication with the proxy.+++noProxy :: Proxy+noProxy = NoProxy++-- | @envProxyString@ locates proxy server settings by looking+-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.)+-- If no mapping found, returns @Nothing@.+envProxyString :: IO (Maybe String)+envProxyString = do+  env <- getEnvironment+  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)++-- | @proxyString@ tries to locate the user's proxy server setting.+-- Consults environment variable, and in case of Windows, by querying+-- the Registry (cf. @registryProxyString@.)+proxyString :: IO (Maybe String)+proxyString = liftM2 mplus envProxyString registryProxyString++registryProxyString :: IO (Maybe String)+#if !defined(WIN32)+registryProxyString = return Nothing+#else+registryProxyLoc :: (HKEY,String)+registryProxyLoc = (hive, path)+  where+    -- some sources say proxy settings should be at +    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+    --                   \CurrentVersion\Internet Settings\ProxyServer+    -- but if the user sets them with IE connection panel they seem to+    -- end up in the following place:+    hive  = hKEY_CURRENT_USER+    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++-- read proxy settings from the windows registry; this is just a best+-- effort and may not work on all setups. +registryProxyString = Prelude.catch+  (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do+    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+    if enable+        then fmap Just $ regQueryValue hkey (Just "ProxyServer")+        else return Nothing)+  (\_ -> return Nothing)+#endif++-- | @fetchProxy flg@ gets the local proxy settings and parse the string+-- into a @Proxy@ value. If you want to be informed of ill-formed proxy+-- configuration strings, supply @True@ for @flg@.+-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable,+-- and in the case of Windows platforms, by consulting IE/WinInet's proxy+-- setting in the Registry.+fetchProxy :: Bool -> IO Proxy+fetchProxy warnIfIllformed = do+  mstr <- proxyString+  case mstr of+    Nothing     -> return NoProxy+    Just str    -> case parseProxy str of+        Just p  -> return p                   +        Nothing -> do+            when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines+                    [ "invalid http proxy uri: " ++ show str+                    , "proxy uri must be http with a hostname"+                    , "ignoring http proxy, trying a direct connection"+                    ]+            return NoProxy++-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value;+-- returns @Nothing@ if not well-formed.+parseProxy :: String -> Maybe Proxy+parseProxy str = join+                   . fmap uri2proxy+                   $ parseHttpURI str+             `mplus` parseHttpURI ("http://" ++ str)+  where+   parseHttpURI str' =+    case parseAbsoluteURI str' of+      Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri)+      _  -> Nothing++     -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+     -- which lack the @\"http://\"@ URI scheme. The problem is that+     -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+     -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+     --+     -- So our strategy is to try parsing as normal uri first and if it lacks the+     -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+     --++-- | tidy up user portion, don't want the trailing "\@".+fixUserInfo :: URI -> URI+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }+  where+   f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s}++-- +uri2proxy :: URI -> Maybe Proxy+uri2proxy uri@URI{ uriScheme    = "http:"+                 , uriAuthority = Just (URIAuth auth' hst prt)+                 } =+ Just (Proxy (hst ++ prt) auth)+  where+   auth =+     case auth' of+       [] -> Nothing+       as -> Just (AuthBasic "" usr pwd uri)+        where+	 (usr,pwd) = chopAtDelim ':' as++uri2proxy _ = Nothing++-- utilities+#if defined(WIN32)+regQueryValueDWORD :: HKEY -> String -> IO DWORD+regQueryValueDWORD hkey name = alloca $ \ptr -> do+  regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+  peek ptr++#endif
+ Network/HTTP/Stream.hs view
@@ -0,0 +1,230 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Stream+-- Copyright   :  See LICENSE file+-- License     :  BSD+-- +-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Transmitting HTTP requests and responses holding @String@ in their payload bodies.+-- This is one of the implementation modules for the "Network.HTTP" interface, representing+-- request and response content as @String@s and transmitting them in non-packed form+-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles.+-- It is mostly here for backwards compatibility, representing how requests and responses+-- were transmitted up until the 4.x releases of the HTTP package.+--+-- For more detailed information about what the individual exports do, please consult+-- the documentation for "Network.HTTP". /Notice/ however that the functions here do+-- not perform any kind of normalization prior to transmission (or receipt); you are+-- responsible for doing any such yourself, or, if you prefer, just switch to using+-- "Network.HTTP" function instead.+-- +-----------------------------------------------------------------------------+module Network.HTTP.Stream +       ( module Network.Stream++       , simpleHTTP      -- :: Request_String -> IO (Result Response_String)+       , simpleHTTP_     -- :: Stream s => s -> Request_String -> IO (Result Response_String)+       , sendHTTP        -- :: Stream s => s -> Request_String -> IO (Result Response_String)+       , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)+       , receiveHTTP     -- :: Stream s => s -> IO (Result Request_String)+       , respondHTTP     -- :: Stream s => s -> Response_String -> IO ()+       +       ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.Stream+import Network.StreamDebugger (debugStream)+import Network.TCP (openTCPPort)+import Network.BufferType ( stringBufferOp )++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim )++import Data.Char     (toLower)+import Data.Maybe    (fromMaybe)+import Control.Monad (when)+++-- Turn on to enable HTTP traffic logging+debug :: Bool+debug = False++-- File that HTTP traffic logs go to+httpLogFile :: String+httpLogFile = "http-debug.log"++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------+++-- | Simple way to transmit a resource across a non-persistent connection.+simpleHTTP :: Request_String -> IO (Result Response_String)+simpleHTTP r = do +   auth <- getAuth r+   c    <- openTCPPort (host auth) (fromMaybe 80 (port auth))+   simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String)+simpleHTTP_ s r+ | not debug    = sendHTTP s r+ | otherwise    = do+      s' <- debugStream httpLogFile s+      sendHTTP s' r++sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String)+sendHTTP conn rq = sendHTTP_notify conn rq (return ())++sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)+sendHTTP_notify conn rq onSendComplete = do+   when providedClose $ (closeOnEnd conn True)+   catchIO (sendMain conn rq onSendComplete)+           (\e -> do { close conn; ioError e })+ where+  providedClose = findConnClose (rqHeaders rq)++-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)+sendMain conn rqst onSendComplete =  do +    --let str = if null (rqBody rqst)+    --              then show rqst+    --              else show (insertHeader HdrExpect "100-continue" rqst)+   writeBlock conn (show rqst)+    -- write body immediately, don't wait for 100 CONTINUE+   writeBlock conn (rqBody rqst)+   onSendComplete+   rsp <- getResponseHead conn+   switchResponse conn True False rsp rqst+        +-- reads and parses headers+getResponseHead :: Stream s => s -> IO (Result ResponseData)+getResponseHead conn = do+   lor <- readTillEmpty1 stringBufferOp (readLine conn)+   return $ lor >>= parseResponseHead++-- Hmmm, this could go bad if we keep getting "100 Continue"+-- responses...  Except this should never happen according+-- to the RFC.+switchResponse :: Stream s+               => s+	       -> Bool {- allow retry? -}+               -> Bool {- is body sent? -}+               -> Result ResponseData+               -> Request_String+               -> IO (Result Response_String)+switchResponse _ _ _ (Left e) _ = return (Left e)+        -- retry on connreset?+        -- if we attempt to use the same socket then there is an excellent+        -- chance that the socket is not in a completely closed state.+switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+            case matchResponse (rqMethod rqst) cd of+                Continue+                    | not bdy_sent -> {- Time to send the body -}+                        do { val <- writeBlock conn (rqBody rqst)+                           ; case val of+                                Left e -> return (Left e)+                                Right _ ->+                                    do { rsp <- getResponseHead conn+                                       ; switchResponse conn allow_retry True rsp rqst+                                       }+                           }+                    | otherwise -> {- keep waiting -}+                        do { rsp <- getResponseHead conn+                           ; switchResponse conn allow_retry bdy_sent rsp rqst                           +                           }++                Retry -> {- Request with "Expect" header failed.+                                Trouble is the request contains Expects+                                other than "100-Continue" -}+                    do { writeBlock conn (show rqst ++ rqBody rqst)+                       ; rsp <- getResponseHead conn+                       ; switchResponse conn False bdy_sent rsp rqst+                       }   +                     +                Done -> do+		    when (findConnClose hdrs)+            	    	 (closeOnEnd conn True)+                    return (Right $ Response cd rn hdrs "")++                DieHorribly str -> do+		    close conn+                    return $ responseParseError "sendHTTP" ("Invalid response: " ++ str)++                ExpectEntity ->+                    let tc = lookupHeader HdrTransferEncoding hdrs+                        cl = lookupHeader HdrContentLength hdrs+                    in+                    do { rslt <- case tc of+                          Nothing -> +                              case cl of+                                  Just x  -> linearTransfer (readBlock conn) (read x :: Int)+                                  Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) []+                          Just x  -> +                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer stringBufferOp+				                               (readLine conn) (readBlock conn)+                                  _         -> uglyDeathTransfer "sendHTTP"+                       ; case rslt of+		           Left e -> close conn >> return (Left e)+			   Right (ftrs,bdy) -> do+			    when (findConnClose (hdrs++ftrs))+			    	 (closeOnEnd conn True)+			    return (Right (Response cd rn (hdrs++ftrs) bdy))+                       }++-- | Receive and parse a HTTP request from the given Stream. Should be used +--   for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request_String)+receiveHTTP conn = getRequestHead >>= processRequest+    where+        -- reads and parses headers+        getRequestHead :: IO (Result RequestData)+        getRequestHead =+            do { lor <- readTillEmpty1 stringBufferOp (readLine conn)+               ; return $ lor >>= parseRequestHead+               }+	+        processRequest (Left e) = return $ Left e+	processRequest (Right (rm,uri,hdrs)) = +	    do -- FIXME : Also handle 100-continue.+               let tc = lookupHeader HdrTransferEncoding hdrs+                   cl = lookupHeader HdrContentLength hdrs+	       rslt <- case tc of+                          Nothing ->+                              case cl of+                                  Just x  -> linearTransfer (readBlock conn) (read x :: Int)+                                  Nothing -> return (Right ([], "")) -- hopefulTransfer ""+                          Just x  ->+                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer stringBufferOp+				                               (readLine conn) (readBlock conn)+                                  _         -> uglyDeathTransfer "receiveHTTP"+               +               return $ do+	          (ftrs,bdy) <- rslt+		  return (Request uri rm (hdrs++ftrs) bdy)++-- | Very simple function, send a HTTP response over the given stream. This +--   could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response_String -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+                          -- write body immediately, don't wait for 100 CONTINUE+                          writeBlock conn (rspBody rsp)+			  return ()
+ Network/HTTP/Utils.hs view
@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Utils+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Set of utility functions and definitions used by package modules.+--+module Network.HTTP.Utils+       ( trim     -- :: String -> String+       , trimL    -- :: String -> String+       , trimR    -- :: String -> String+       +       , crlf     -- :: String+       , lf       -- :: String+       , sp       -- :: String++       , split    -- :: Eq a => a -> [a] -> Maybe ([a],[a])+       , splitBy  -- :: Eq a => a -> [a] -> [[a]]+       +       , readsOne -- :: Read a => (a -> b) -> b -> String -> b++       , dropWhileTail -- :: (a -> Bool) -> [a] -> [a]+       , chopAtDelim   -- :: Eq a => a -> [a] -> ([a],[a])+       +       ) where+       +import Data.Char+import Data.List ( elemIndex )+import Data.Maybe ( fromMaybe )++-- | @crlf@ is our beloved two-char line terminator.+crlf :: String+crlf = "\r\n"++-- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3.+lf :: String+lf = "\n"++-- | @sp@ lets you save typing one character.+sp :: String+sp   = " "++-- | @split delim ls@ splits a list into two parts, the @delim@ occurring+-- at the head of the second list.  If @delim@ isn't in @ls@, @Nothing@ is+-- returned.+split :: Eq a => a -> [a] -> Maybe ([a],[a])+split delim list = case delim `elemIndex` list of+    Nothing -> Nothing+    Just x  -> Just $ splitAt x list++-- | @trim str@ removes leading and trailing whitespace from @str@.+trim :: String -> String+trim xs = trimR (trimL xs)+   +-- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace')+-- from @str@.+trimL :: String -> String+trimL xs = dropWhile isSpace xs++-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace')+-- from @str@.+trimR :: String -> String+trimR str = fromMaybe "" $ foldr trimIt Nothing str+ where+  trimIt x (Just xs) = Just (x:xs)+  trimIt x Nothing   +   | isSpace x = Nothing+   | otherwise = Just [x]++-- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@.+splitBy :: Eq a => a -> [a] -> [[a]]+splitBy _ [] = []+splitBy c xs = +    case break (==c) xs of+      (_,[]) -> [xs]+      (as,_:bs) -> as : splitBy c bs++-- | @readsOne f def str@ tries to 'read' @str@, taking+-- the first result and passing it to @f@. If the 'read'+-- doesn't succeed, return @def@.+readsOne :: Read a => (a -> b) -> b -> String -> b+readsOne f n str = + case reads str of+   ((v,_):_) -> f v+   _ -> n+++-- | @dropWhileTail p ls@ chops off trailing elements from @ls@+-- until @p@ returns @False@.+dropWhileTail :: (a -> Bool) -> [a] -> [a]+dropWhileTail f ls =+ case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] }+  where+    chop x (Just xs) = Just (x:xs)+    chop x _+     | f x       = Nothing+     | otherwise = Just [x]++-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence+-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second+-- list is empty and the first is equal to @ls@.+chopAtDelim :: Eq a => a -> [a] -> ([a],[a])+chopAtDelim elt xs =+  case break (==elt) xs of+    (_,[])    -> (xs,[])+    (as,_:bs) -> (as,bs)
+ Network/Socket.hsc view
@@ -0,0 +1,2236 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-do-bind #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.Socket+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/network/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The "Network.Socket" module is for when you want full control over+-- sockets.  Essentially the entire C socket API is exposed through+-- this module; in general the operations follow the behaviour of the C+-- functions of the same name (consult your favourite Unix networking book).+--+-- A higher level interface to networking operations is provided+-- through the module "Network".+--+-----------------------------------------------------------------------------++#include "HsNet.h"++-- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs.+##include "Typeable.h"++-- In order to process this file, you need to have CALLCONV defined.++module Network.Socket+    (+    -- * Types+      Socket(..)+    , Family(..)         +    , SocketType(..)+    , SockAddr(..)+    , SocketStatus(..)+    , HostAddress+#if defined(IPV6_SOCKET_SUPPORT)+    , HostAddress6+    , FlowInfo+    , ScopeID+#endif+    , ShutdownCmd(..)+    , ProtocolNumber+    , defaultProtocol+    , PortNumber(..)+    -- PortNumber is used non-abstractly in Network.BSD.  ToDo: remove+    -- this use and make the type abstract.++    -- * Address operations++    , HostName+    , ServiceName++#if defined(IPV6_SOCKET_SUPPORT)+    , AddrInfo(..)++    , AddrInfoFlag(..)+    , addrInfoFlagImplemented++    , defaultHints++    , getAddrInfo++    , NameInfoFlag(..)++    , getNameInfo+#endif++    -- * Socket operations+    , socket+#if defined(DOMAIN_SOCKET_SUPPORT)+    , socketPair+#endif+    , connect+    , bindSocket+    , listen+    , accept+    , getPeerName+    , getSocketName++#ifdef HAVE_STRUCT_UCRED+    -- get the credentials of our domain socket peer.+    , getPeerCred+#endif++    , socketPort++    , socketToHandle++    -- ** Sending and receiving data+    -- $sendrecv+    , sendTo+    , sendBufTo++    , recvFrom+    , recvBufFrom+    +    , send+    , recv+    , recvLen++    , inet_addr+    , inet_ntoa++    , shutdown+    , sClose++    -- ** Predicates on sockets+    , sIsConnected+    , sIsBound+    , sIsListening+    , sIsReadable+    , sIsWritable++    -- * Socket options+    , SocketOption(..)+    , getSocketOption+    , setSocketOption++    -- * File descriptor transmission+#ifdef DOMAIN_SOCKET_SUPPORT+    , sendFd+    , recvFd++    -- Note: these two will disappear shortly+    , sendAncillary+    , recvAncillary++#endif++    -- * Special constants+    , aNY_PORT+    , iNADDR_ANY+#if defined(IPV6_SOCKET_SUPPORT)+    , iN6ADDR_ANY+#endif+    , sOMAXCONN+    , sOL_SOCKET+#ifdef SCM_RIGHTS+    , sCM_RIGHTS+#endif+    , maxListenQueue++    -- * Initialisation+    , withSocketsDo+    +    -- * Very low level operations+    -- in case you ever want to get at the underlying file descriptor..+    , fdSocket+    , mkSocket++    -- * Internal++    -- | The following are exported ONLY for use in the BSD module and+    -- should not be used anywhere else.++    , packFamily+    , unpackFamily+    , packSocketType+    , throwSocketErrorIfMinus1_+    ) where++#ifdef __HUGS__+import Hugs.Prelude ( IOException(..), IOErrorType(..) )+import Hugs.IO ( openFd )++{-# CFILES cbits/HsNet.c #-}+# if HAVE_STRUCT_MSGHDR_MSG_CONTROL || HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS+{-# CFILES cbits/ancilData.c #-}+# endif+# if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__)+{-# CFILES cbits/initWinSock.c cbits/winSockErr.c #-}+# endif+#endif++import Data.Bits+import Data.List (foldl')+import Data.Word (Word16, Word32)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (Storable(..))+import Foreign.C.Error+import Foreign.C.String (CString, withCString, peekCString, peekCStringLen)+import Foreign.C.Types (CUInt, CChar)+#if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types (CInt(..), CSize(..))+#else+import Foreign.C.Types (CInt, CSize)+#endif+import Foreign.Marshal.Alloc ( alloca, allocaBytes )+import Foreign.Marshal.Array ( peekArray )+import Foreign.Marshal.Utils ( maybeWith, with )++import System.IO+import Control.Monad (liftM, when)+import Data.Ratio ((%))++import qualified Control.Exception+import Control.Concurrent.MVar+import Data.Typeable+import System.IO.Error++#ifdef __GLASGOW_HASKELL__+import GHC.Conc (threadWaitRead, threadWaitWrite)+##if MIN_VERSION_base(4,3,1)+import GHC.Conc (closeFdWith)+##endif+# if defined(mingw32_HOST_OS)+import GHC.Conc (asyncDoProc)+import Foreign (FunPtr)+# endif+# if __GLASGOW_HASKELL__ >= 611+import qualified GHC.IO.Device+import GHC.IO.Handle.FD+import GHC.IO.Exception+import GHC.IO+# else+import GHC.IOBase+import GHC.Handle+# endif+import qualified System.Posix.Internals+#else+import System.IO.Unsafe (unsafePerformIO)+#endif++# if __GLASGOW_HASKELL__ >= 611+import GHC.IO.FD+#endif++import Network.Socket.Internal++-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host+-- address string consisting of a dotted decimal IPv4 address or an+-- IPv6 address e.g., @\"192.168.0.1\"@.+type HostName       = String+type ServiceName    = String++-- ----------------------------------------------------------------------------+-- On Windows, our sockets are not put in non-blocking mode (non-blocking+-- is not supported for regular file descriptors on Windows, and it would+-- be a pain to support it only for sockets).  So there are two cases:+--+--  - the threaded RTS uses safe calls for socket operations to get+--    non-blocking I/O, just like the rest of the I/O library+--+--  - with the non-threaded RTS, only some operations on sockets will be+--    non-blocking.  Reads and writes go through the normal async I/O+--    system.  accept() uses asyncDoProc so is non-blocking.  A handful+--    of others (recvFrom, sendFd, recvFd) will block all threads - if this+--    is a problem, -threaded is the workaround.+--+##if defined(mingw32_HOST_OS)+##define SAFE_ON_WIN safe+##else+##define SAFE_ON_WIN unsafe+##endif++-----------------------------------------------------------------------------+-- Socket types++-- There are a few possible ways to do this.  The first is convert the+-- structs used in the C library into an equivalent Haskell type. An+-- other possible implementation is to keep all the internals in the C+-- code and use an Int## and a status flag. The second method is used+-- here since a lot of the C structures are not required to be+-- manipulated.++-- Originally the status was non-mutable so we had to return a new+-- socket each time we changed the status.  This version now uses+-- mutable variables to avoid the need to do this.  The result is a+-- cleaner interface and better security since the application+-- programmer now can't circumvent the status information to perform+-- invalid operations on sockets.++data SocketStatus+  -- Returned Status    Function called+  = NotConnected        -- socket+  | Bound               -- bindSocket+  | Listening           -- listen+  | Connected           -- connect/accept+  | ConvertedToHandle   -- is now a Handle, don't touch+  | Closed              -- sClose +    deriving (Eq, Show, Typeable)++data Socket+  = MkSocket+            CInt                 -- File Descriptor+            Family                                +            SocketType                            +            ProtocolNumber       -- Protocol Number+            (MVar SocketStatus)  -- Status Flag+  deriving Typeable++#if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS)+socket2FD  (MkSocket fd _ _ _ _) = +  -- HACK, 1 means True +  FD{fdFD = fd,fdIsSocket_ = 1} +#endif++mkSocket :: CInt+         -> Family+         -> SocketType+         -> ProtocolNumber+         -> SocketStatus+         -> IO Socket+mkSocket fd fam sType pNum stat = do+   mStat <- newMVar stat+   return (MkSocket fd fam sType pNum mStat)++instance Eq Socket where+  (MkSocket _ _ _ _ m1) == (MkSocket _ _ _ _ m2) = m1 == m2++instance Show Socket where+  showsPrec _n (MkSocket fd _ _ _ _) =+        showString "<socket: " . shows fd . showString ">"+++fdSocket :: Socket -> CInt+fdSocket (MkSocket fd _ _ _ _) = fd++type ProtocolNumber = CInt++-- | This is the default protocol for a given service.+defaultProtocol :: ProtocolNumber+defaultProtocol = 0++----------------------------------------------------------------------------+-- Port Numbers++instance Show PortNumber where+  showsPrec p pn = showsPrec p (portNumberToInt pn)++intToPortNumber :: Int -> PortNumber+intToPortNumber v = PortNum (htons (fromIntegral v))++portNumberToInt :: PortNumber -> Int+portNumberToInt (PortNum po) = fromIntegral (ntohs po)++foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16+foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16+--foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32+foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32++instance Enum PortNumber where+    toEnum   = intToPortNumber+    fromEnum = portNumberToInt++instance Num PortNumber where+   fromInteger i = intToPortNumber (fromInteger i)+    -- for completeness.+   (+) x y   = intToPortNumber (portNumberToInt x + portNumberToInt y)+   (-) x y   = intToPortNumber (portNumberToInt x - portNumberToInt y)+   negate x  = intToPortNumber (-portNumberToInt x)+   (*) x y   = intToPortNumber (portNumberToInt x * portNumberToInt y)+   abs n     = intToPortNumber (abs (portNumberToInt n))+   signum n  = intToPortNumber (signum (portNumberToInt n))++instance Real PortNumber where+    toRational x = toInteger x % 1++instance Integral PortNumber where+    quotRem a b = let (c,d) = quotRem (portNumberToInt a) (portNumberToInt b) in+                  (intToPortNumber c, intToPortNumber d)+    toInteger a = toInteger (portNumberToInt a)++instance Storable PortNumber where+   sizeOf    _ = sizeOf    (undefined :: Word16)+   alignment _ = alignment (undefined :: Word16)+   poke p (PortNum po) = poke (castPtr p) po+   peek p = PortNum `liftM` peek (castPtr p)++-----------------------------------------------------------------------------+-- SockAddr++instance Show SockAddr where+#if defined(DOMAIN_SOCKET_SUPPORT)+  showsPrec _ (SockAddrUnix str) = showString str+#endif+  showsPrec _ (SockAddrInet port ha)+   = showString (unsafePerformIO (inet_ntoa ha)) +   . showString ":"+   . shows port+#if defined(IPV6_SOCKET_SUPPORT)+  showsPrec _ addr@(SockAddrInet6 port _ _ _)+   = showChar '['+   . showString (unsafePerformIO $+                 fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>=+                 maybe (fail "showsPrec: impossible internal error") return)+   . showString "]:"+   . shows port+#endif++-----------------------------------------------------------------------------+-- Connection Functions++-- In the following connection and binding primitives.  The names of+-- the equivalent C functions have been preserved where possible. It+-- should be noted that some of these names used in the C library,+-- \tr{bind} in particular, have a different meaning to many Haskell+-- programmers and have thus been renamed by appending the prefix+-- Socket.++-- | Create a new socket using the given address family, socket type+-- and protocol number.  The address family is usually 'AF_INET',+-- 'AF_INET6', or 'AF_UNIX'.  The socket type is usually 'Stream' or+-- 'Datagram'.  The protocol number is usually 'defaultProtocol'.+-- If 'AF_INET6' is used, the 'IPv6Only' socket option is set to 0+-- so that both IPv4 and IPv6 can be handled with one socket.+socket :: Family         -- Family Name (usually AF_INET)+       -> SocketType     -- Socket Type (usually Stream)+       -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)+       -> IO Socket      -- Unconnected Socket+socket family stype protocol = do+    fd <- throwSocketErrorIfMinus1Retry "socket" $+                c_socket (packFamily family) (packSocketType stype) protocol+#if !defined(__HUGS__)+# if __GLASGOW_HASKELL__ < 611+    System.Posix.Internals.setNonBlockingFD fd+# else+    System.Posix.Internals.setNonBlockingFD fd True+# endif+#endif+    socket_status <- newMVar NotConnected+    let sock = MkSocket fd family stype protocol socket_status+#if HAVE_DECL_IPV6_V6ONLY+# if defined(mingw32_HOST_OS)+    -- the IPv6Only option is only supported on Windows Vista and later,+    -- so trying to change it might throw an error+    when (family == AF_INET6) $+            catch (setSocketOption sock IPv6Only 0) $ const $ return ()+# else+    when (family == AF_INET6) $ setSocketOption sock IPv6Only 0+# endif+#endif+    return sock++-- | Build a pair of connected socket objects using the given address+-- family, socket type, and protocol number.  Address family, socket+-- type, and protocol number are as for the 'socket' function above.+-- Availability: Unix.+#if defined(DOMAIN_SOCKET_SUPPORT)+socketPair :: Family              -- Family Name (usually AF_INET or AF_INET6)+           -> SocketType          -- Socket Type (usually Stream)+           -> ProtocolNumber      -- Protocol Number+           -> IO (Socket, Socket) -- unnamed and connected.+socketPair family stype protocol = do+    allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do+    _rc <- throwSocketErrorIfMinus1Retry "socketpair" $+                c_socketpair (packFamily family)+                             (packSocketType stype)+                             protocol fdArr+    [fd1,fd2] <- peekArray 2 fdArr +    s1 <- mkNonBlockingSocket fd1+    s2 <- mkNonBlockingSocket fd2+    return (s1,s2)+  where+    mkNonBlockingSocket fd = do+#if !defined(__HUGS__)+# if __GLASGOW_HASKELL__ < 611+       System.Posix.Internals.setNonBlockingFD fd+# else+       System.Posix.Internals.setNonBlockingFD fd True+# endif+#endif+       stat <- newMVar Connected+       return (MkSocket fd family stype protocol stat)++foreign import ccall unsafe "socketpair"+  c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt+#endif++-----------------------------------------------------------------------------+-- Binding a socket++-- | Bind the socket to an address. The socket must not already be+-- bound.  The 'Family' passed to @bindSocket@ must be the+-- same as that passed to 'socket'.  If the special port number+-- 'aNY_PORT' is passed then the system assigns the next available+-- use port.+bindSocket :: Socket    -- Unconnected Socket+           -> SockAddr  -- Address to Bind to+           -> IO ()+bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do+ modifyMVar_ socketStatus $ \ status -> do+ if status /= NotConnected +  then+   ioError (userError ("bindSocket: can't peform bind on socket in status " +++         show status))+  else do+   withSockAddr addr $ \p_addr sz -> do+   _status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz)+   return Bound++-----------------------------------------------------------------------------+-- Connecting a socket++-- | Connect to a remote socket at address.+connect :: Socket    -- Unconnected Socket+        -> SockAddr  -- Socket address stuff+        -> IO ()+connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do+ modifyMVar_ socketStatus $ \currentStatus -> do+ if currentStatus /= NotConnected && currentStatus /= Bound+  then+    ioError (userError ("connect: can't peform connect on socket in status " +++        show currentStatus))+  else do+    withSockAddr addr $ \p_addr sz -> do++    let connectLoop = do+           r <- c_connect s p_addr (fromIntegral sz)+           if r == -1+               then do +#if !(defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS))+                   err <- getErrno+                   case () of+                     _ | err == eINTR       -> connectLoop+                     _ | err == eINPROGRESS -> connectBlocked+--                   _ | err == eAGAIN      -> connectBlocked+                     _otherwise             -> throwSocketError "connect"+#else+                   rc <- c_getLastError+                   case rc of+                     10093 -> do -- WSANOTINITIALISED+                       withSocketsDo (return ())+                       r <- c_connect s p_addr (fromIntegral sz)+                       if r == -1+                         then throwSocketError "connect"+                         else return r+                     _ -> throwSocketError "connect"+#endif+               else return r++        connectBlocked = do +#if !defined(__HUGS__)+           threadWaitWrite (fromIntegral s)+#endif+           err <- getSocketOption sock SoError+           if (err == 0)+                then return 0+                else do ioError (errnoToIOError "connect" +                                (Errno (fromIntegral err))+                                Nothing Nothing)++    connectLoop+    return Connected++-----------------------------------------------------------------------------+-- Listen++-- | Listen for connections made to the socket.  The second argument+-- specifies the maximum number of queued connections and should be at+-- least 1; the maximum value is system-dependent (usually 5).+listen :: Socket  -- Connected & Bound Socket+       -> Int     -- Queue Length+       -> IO ()+listen (MkSocket s _family _stype _protocol socketStatus) backlog = do+ modifyMVar_ socketStatus $ \ status -> do+ if status /= Bound +   then+     ioError (userError ("listen: can't peform listen on socket in status " +++         show status))+   else do+     throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog))+     return Listening++-----------------------------------------------------------------------------+-- Accept+--+-- A call to `accept' only returns when data is available on the given+-- socket, unless the socket has been set to non-blocking.  It will+-- return a new socket which should be used to read the incoming data and+-- should then be closed. Using the socket returned by `accept' allows+-- incoming requests to be queued on the original socket.++-- | Accept a connection.  The socket must be bound to an address and+-- listening for connections.  The return value is a pair @(conn,+-- address)@ where @conn@ is a new socket object usable to send and+-- receive data on the connection, and @address@ is the address bound+-- to the socket on the other end of the connection.+accept :: Socket                        -- Queue Socket+       -> IO (Socket,                   -- Readable Socket+              SockAddr)                 -- Peer details++accept sock@(MkSocket s family stype protocol status) = do+ currentStatus <- readMVar status+ okay <- sIsAcceptable sock+ if not okay+   then+     ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " +++         show currentStatus))+   else do+     let sz = sizeOfSockAddrByFamily family+     allocaBytes sz $ \ sockaddr -> do+#if defined(mingw32_HOST_OS) && defined(__GLASGOW_HASKELL__)+     new_sock <-+        if threaded +           then with (fromIntegral sz) $ \ ptr_len ->+                  throwErrnoIfMinus1Retry "Network.Socket.accept" $+                    c_accept_safe s sockaddr ptr_len+           else do+                paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr+                rc        <- asyncDoProc c_acceptDoProc paramData+                new_sock  <- c_acceptNewSock    paramData+                c_free paramData+                when (rc /= 0)+                     (ioError (errnoToIOError "Network.Socket.accept" (Errno (fromIntegral rc)) Nothing Nothing))+                return new_sock+#else +     with (fromIntegral sz) $ \ ptr_len -> do+     new_sock <- +# if !defined(__HUGS__)+                 throwSocketErrorIfMinus1RetryMayBlock "accept"+                        (threadWaitRead (fromIntegral s))+# endif+                        (c_accept s sockaddr ptr_len)+# if !defined(__HUGS__)+#  if __GLASGOW_HASKELL__ < 611+     System.Posix.Internals.setNonBlockingFD new_sock+#  else+     System.Posix.Internals.setNonBlockingFD new_sock True+#  endif+# endif+#endif+     addr <- peekSockAddr sockaddr+     new_status <- newMVar Connected+     return ((MkSocket new_sock family stype protocol new_status), addr)++#if defined(mingw32_HOST_OS) && !defined(__HUGS__)+foreign import ccall unsafe "HsNet.h acceptNewSock"+  c_acceptNewSock :: Ptr () -> IO CInt+foreign import ccall unsafe "HsNet.h newAcceptParams"+  c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())+foreign import ccall unsafe "HsNet.h &acceptDoProc"+  c_acceptDoProc :: FunPtr (Ptr () -> IO Int)+foreign import ccall unsafe "free"+  c_free:: Ptr a -> IO ()+#endif++-----------------------------------------------------------------------------+-- ** Sending and reciving data++-- $sendrecv+--+-- Do not use the @send@ and @recv@ functions defined in this module+-- in new code, as they incorrectly represent binary data as a Unicode+-- string.  As a result, these functions are inefficient and may lead+-- to bugs in the program.  Instead use the @send@ and @recv@+-- functions defined in the 'Network.Socket.ByteString' module.++-----------------------------------------------------------------------------+-- sendTo & recvFrom++-- | Send data to the socket.  The recipient can be specified+-- explicitly, so the socket need not be in a connected state.+-- Returns the number of bytes sent.  Applications are responsible for+-- ensuring that all data has been sent.+--+-- NOTE: blocking on Windows unless you compile with -threaded (see+-- GHC ticket #1129)+sendTo :: Socket        -- (possibly) bound/connected Socket+       -> String        -- Data to send+       -> SockAddr+       -> IO Int        -- Number of Bytes sent+sendTo sock xs addr = do+ withCString xs $ \str -> do+   sendBufTo sock str (length xs) addr++-- | Send data to the socket.  The recipient can be specified+-- explicitly, so the socket need not be in a connected state.+-- Returns the number of bytes sent.  Applications are responsible for+-- ensuring that all data has been sent.+sendBufTo :: Socket            -- (possibly) bound/connected Socket+          -> Ptr a -> Int  -- Data to send+          -> SockAddr+          -> IO Int            -- Number of Bytes sent+sendBufTo (MkSocket s _family _stype _protocol _status) ptr nbytes addr = do+ withSockAddr addr $ \p_addr sz -> do+   liftM fromIntegral $+#if !defined(__HUGS__)+     throwSocketErrorIfMinus1RetryMayBlock "sendTo"+        (threadWaitWrite (fromIntegral s)) $+#endif+        c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-} +                        p_addr (fromIntegral sz)++-- | Receive data from the socket. The socket need not be in a+-- connected state. Returns @(bytes, nbytes, address)@ where @bytes@+-- is a @String@ of length @nbytes@ representing the data received and+-- @address@ is a 'SockAddr' representing the address of the sending+-- socket.+--+-- NOTE: blocking on Windows unless you compile with -threaded (see+-- GHC ticket #1129)+recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)+recvFrom sock nbytes =+  allocaBytes nbytes $ \ptr -> do+    (len, sockaddr) <- recvBufFrom sock ptr nbytes+    str <- peekCStringLen (ptr, len)+    return (str, len, sockaddr)++-- | Receive data from the socket, writing it into buffer instead of+-- creating a new string.  The socket need not be in a connected+-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of+-- bytes received and @address@ is a 'SockAddr' representing the+-- address of the sending socket.+--+-- NOTE: blocking on Windows unless you compile with -threaded (see+-- GHC ticket #1129)+recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)+recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes+ | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")+ | otherwise   = +    withNewSockAddr family $ \ptr_addr sz -> do+      alloca $ \ptr_len -> do+        poke ptr_len (fromIntegral sz)+        len <- +#if !defined(__HUGS__)+               throwSocketErrorIfMinus1RetryMayBlock "recvFrom"+                   (threadWaitRead (fromIntegral s)) $+#endif+                   c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-} +                                ptr_addr ptr_len+        let len' = fromIntegral len+        if len' == 0+         then ioError (mkEOFError "Network.Socket.recvFrom")+         else do+           flg <- sIsConnected sock+             -- For at least one implementation (WinSock 2), recvfrom() ignores+             -- filling in the sockaddr for connected TCP sockets. Cope with +             -- this by using getPeerName instead.+           sockaddr <- +                if flg then+                   getPeerName sock+                else+                   peekSockAddr ptr_addr +           return (len', sockaddr)++-----------------------------------------------------------------------------+-- send & recv++-- | Send data to the socket. The socket must be connected to a remote+-- socket. Returns the number of bytes sent.  Applications are+-- responsible for ensuring that all data has been sent.+send :: Socket  -- Bound/Connected Socket+     -> String  -- Data to send+     -> IO Int  -- Number of Bytes sent+send sock@(MkSocket s _family _stype _protocol _status) xs = do+ let len = length xs+ withCString xs $ \str -> do+   liftM fromIntegral $+#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)+# if __GLASGOW_HASKELL__ >= 611    +    writeRawBufferPtr +      "Network.Socket.send" +      (socket2FD sock)+      (castPtr str)+      0+      (fromIntegral len)+#else      +      writeRawBufferPtr +        "Network.Socket.send" +        (fromIntegral s) +        True +        str +        0 +       (fromIntegral len)+#endif    +    +#else+# if !defined(__HUGS__)+     throwSocketErrorIfMinus1RetryMayBlock "send"+        (threadWaitWrite (fromIntegral s)) $+# endif+        c_send s str (fromIntegral len) 0{-flags-} +#endif++-- | Receive data from the socket.  The socket must be in a connected+-- state. This function may return fewer bytes than specified.  If the+-- message is longer than the specified length, it may be discarded+-- depending on the type of socket.  This function may block until a+-- message arrives.+--+-- Considering hardware and network realities, the maximum number of+-- bytes to receive should be a small power of 2, e.g., 4096.+--+-- For TCP sockets, a zero length return value means the peer has+-- closed its half side of the connection.+recv :: Socket -> Int -> IO String+recv sock l = recvLen sock l >>= \ (s,_) -> return s++recvLen :: Socket -> Int -> IO (String, Int)+recvLen sock@(MkSocket s _family _stype _protocol _status) nbytes+ | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")+ | otherwise   = do+     allocaBytes nbytes $ \ptr -> do+        len <- +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)+# if __GLASGOW_HASKELL__ >= 611    +          readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0+                 (fromIntegral nbytes)+#else          +          readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0+                 (fromIntegral nbytes)+#endif+#else+# if !defined(__HUGS__)+               throwSocketErrorIfMinus1RetryMayBlock "recv"+                   (threadWaitRead (fromIntegral s)) $+# endif+                   c_recv s ptr (fromIntegral nbytes) 0{-flags-} +#endif+        let len' = fromIntegral len+        if len' == 0+         then ioError (mkEOFError "Network.Socket.recv")+         else do+           s' <- peekCStringLen (castPtr ptr,len')+           return (s', len')++-- ---------------------------------------------------------------------------+-- socketPort+--+-- The port number the given socket is currently connected to can be+-- determined by calling $port$, is generally only useful when bind+-- was given $aNY\_PORT$.++socketPort :: Socket            -- Connected & Bound Socket+           -> IO PortNumber     -- Port Number of Socket+socketPort sock@(MkSocket _ AF_INET _ _ _) = do+    (SockAddrInet port _) <- getSocketName sock+    return port+#if defined(IPV6_SOCKET_SUPPORT)+socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do+    (SockAddrInet6 port _ _ _) <- getSocketName sock+    return port+#endif+socketPort (MkSocket _ family _ _ _) =+    ioError (userError ("socketPort: not supported for Family " ++ show family))+++-- ---------------------------------------------------------------------------+-- getPeerName++-- Calling $getPeerName$ returns the address details of the machine,+-- other than the local one, which is connected to the socket. This is+-- used in programs such as FTP to determine where to send the+-- returning data.  The corresponding call to get the details of the+-- local machine is $getSocketName$.++getPeerName   :: Socket -> IO SockAddr+getPeerName (MkSocket s family _ _ _) = do+ withNewSockAddr family $ \ptr sz -> do+   with (fromIntegral sz) $ \int_star -> do+   throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star+   _sz <- peek int_star+   peekSockAddr ptr+    +getSocketName :: Socket -> IO SockAddr+getSocketName (MkSocket s family _ _ _) = do+ withNewSockAddr family $ \ptr sz -> do+   with (fromIntegral sz) $ \int_star -> do+   throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star+   peekSockAddr ptr++-----------------------------------------------------------------------------+-- Socket Properties++data SocketOption+    = DummySocketOption__+#ifdef SO_DEBUG+    | Debug         {- SO_DEBUG     -}+#endif+#ifdef SO_REUSEADDR+    | ReuseAddr     {- SO_REUSEADDR -}+#endif+#ifdef SO_TYPE+    | Type          {- SO_TYPE      -}+#endif+#ifdef SO_ERROR+    | SoError       {- SO_ERROR     -}+#endif+#ifdef SO_DONTROUTE+    | DontRoute     {- SO_DONTROUTE -}+#endif+#ifdef SO_BROADCAST+    | Broadcast     {- SO_BROADCAST -}+#endif+#ifdef SO_SNDBUF+    | SendBuffer    {- SO_SNDBUF    -}+#endif+#ifdef SO_RCVBUF+    | RecvBuffer    {- SO_RCVBUF    -}+#endif+#ifdef SO_KEEPALIVE+    | KeepAlive     {- SO_KEEPALIVE -}+#endif+#ifdef SO_OOBINLINE+    | OOBInline     {- SO_OOBINLINE -}+#endif+#ifdef IP_TTL+    | TimeToLive    {- IP_TTL       -}+#endif+#ifdef TCP_MAXSEG+    | MaxSegment    {- TCP_MAXSEG   -}+#endif+#ifdef TCP_NODELAY+    | NoDelay       {- TCP_NODELAY  -}+#endif+#ifdef SO_LINGER+    | Linger        {- SO_LINGER    -}+#endif+#ifdef SO_REUSEPORT+    | ReusePort     {- SO_REUSEPORT -}+#endif+#ifdef SO_RCVLOWAT+    | RecvLowWater  {- SO_RCVLOWAT  -}+#endif+#ifdef SO_SNDLOWAT+    | SendLowWater  {- SO_SNDLOWAT  -}+#endif+#ifdef SO_RCVTIMEO+    | RecvTimeOut   {- SO_RCVTIMEO  -}+#endif+#ifdef SO_SNDTIMEO+    | SendTimeOut   {- SO_SNDTIMEO  -}+#endif+#ifdef SO_USELOOPBACK+    | UseLoopBack   {- SO_USELOOPBACK -}+#endif+#if HAVE_DECL_IPV6_V6ONLY+    | IPv6Only      {- IPV6_V6ONLY -}+#endif+    deriving (Show, Typeable)++socketOptLevel :: SocketOption -> CInt+socketOptLevel so = +  case so of+#ifdef IP_TTL+    TimeToLive   -> #const IPPROTO_IP+#endif+#ifdef TCP_MAXSEG+    MaxSegment   -> #const IPPROTO_TCP+#endif+#ifdef TCP_NODELAY+    NoDelay      -> #const IPPROTO_TCP+#endif+#if HAVE_DECL_IPV6_V6ONLY+    IPv6Only     -> #const IPPROTO_IPV6+#endif+    _            -> #const SOL_SOCKET++packSocketOption :: SocketOption -> CInt+packSocketOption so =+  case so of+#ifdef SO_DEBUG+    Debug         -> #const SO_DEBUG+#endif+#ifdef SO_REUSEADDR+    ReuseAddr     -> #const SO_REUSEADDR+#endif+#ifdef SO_TYPE+    Type          -> #const SO_TYPE+#endif+#ifdef SO_ERROR+    SoError       -> #const SO_ERROR+#endif+#ifdef SO_DONTROUTE+    DontRoute     -> #const SO_DONTROUTE+#endif+#ifdef SO_BROADCAST+    Broadcast     -> #const SO_BROADCAST+#endif+#ifdef SO_SNDBUF+    SendBuffer    -> #const SO_SNDBUF+#endif+#ifdef SO_RCVBUF+    RecvBuffer    -> #const SO_RCVBUF+#endif+#ifdef SO_KEEPALIVE+    KeepAlive     -> #const SO_KEEPALIVE+#endif+#ifdef SO_OOBINLINE+    OOBInline     -> #const SO_OOBINLINE+#endif+#ifdef IP_TTL+    TimeToLive    -> #const IP_TTL+#endif+#ifdef TCP_MAXSEG+    MaxSegment    -> #const TCP_MAXSEG+#endif+#ifdef TCP_NODELAY+    NoDelay       -> #const TCP_NODELAY+#endif+#ifdef SO_LINGER+    Linger        -> #const SO_LINGER+#endif+#ifdef SO_REUSEPORT+    ReusePort     -> #const SO_REUSEPORT+#endif+#ifdef SO_RCVLOWAT+    RecvLowWater  -> #const SO_RCVLOWAT+#endif+#ifdef SO_SNDLOWAT+    SendLowWater  -> #const SO_SNDLOWAT+#endif+#ifdef SO_RCVTIMEO+    RecvTimeOut   -> #const SO_RCVTIMEO+#endif+#ifdef SO_SNDTIMEO+    SendTimeOut   -> #const SO_SNDTIMEO+#endif+#ifdef SO_USELOOPBACK+    UseLoopBack   -> #const SO_USELOOPBACK+#endif+#if HAVE_DECL_IPV6_V6ONLY+    IPv6Only      -> #const IPV6_V6ONLY+#endif+    unknown       -> error ("Network.Socket.packSocketOption: unknown option " +++                            show unknown)++setSocketOption :: Socket +                -> SocketOption -- Option Name+                -> Int          -- Option Value+                -> IO ()+setSocketOption (MkSocket s _ _ _ _) so v = do+   with (fromIntegral v) $ \ptr_v -> do+   throwErrnoIfMinus1_ "setSocketOption" $+       c_setsockopt s (socketOptLevel so) (packSocketOption so) ptr_v +          (fromIntegral (sizeOf (undefined :: CInt)))+   return ()+++getSocketOption :: Socket+                -> SocketOption  -- Option Name+                -> IO Int        -- Option Value+getSocketOption (MkSocket s _ _ _ _) so = do+   alloca $ \ptr_v ->+     with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do+       throwErrnoIfMinus1 "getSocketOption" $+         c_getsockopt s (socketOptLevel so) (packSocketOption so) ptr_v ptr_sz+       fromIntegral `liftM` peek ptr_v+++#ifdef HAVE_STRUCT_UCRED+-- | Returns the processID, userID and groupID of the socket's peer.+--+-- Only available on platforms that support SO_PEERCRED on domain sockets.+getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)+getPeerCred sock = do+  let fd = fdSocket sock+  let sz = (fromIntegral (#const sizeof(struct ucred)))+  with sz $ \ ptr_cr -> +   alloca       $ \ ptr_sz -> do+     poke ptr_sz sz+     throwErrnoIfMinus1 "getPeerCred" $+       c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz+     pid <- (#peek struct ucred, pid) ptr_cr+     uid <- (#peek struct ucred, uid) ptr_cr+     gid <- (#peek struct ucred, gid) ptr_cr+     return (pid, uid, gid)+#endif++##if !(MIN_VERSION_base(4,3,1))+closeFdWith closer fd = closer fd+##endif++#if defined(DOMAIN_SOCKET_SUPPORT)+-- sending/receiving ancillary socket data; low-level mechanism+-- for transmitting file descriptors, mainly.+sendFd :: Socket -> CInt -> IO ()+sendFd sock outfd = do+  let fd = fdSocket sock+#if !defined(__HUGS__)+  throwSocketErrorIfMinus1RetryMayBlock "sendFd"+     (threadWaitWrite (fromIntegral fd)) $+     c_sendFd fd outfd+#else+  c_sendFd fd outfd+#endif+   -- Note: If Winsock supported FD-passing, thi would have been +   -- incorrect (since socket FDs need to be closed via closesocket().)+  close outfd+  +recvFd :: Socket -> IO CInt+recvFd sock = do+  let fd = fdSocket sock+  theFd <- +#if !defined(__HUGS__)+    throwSocketErrorIfMinus1RetryMayBlock "recvFd" +        (threadWaitRead (fromIntegral fd)) $+#endif+         c_recvFd fd+  return theFd+++sendAncillary :: Socket+              -> Int+              -> Int+              -> Int+              -> Ptr a+              -> Int+              -> IO ()+sendAncillary sock level ty flags datum len = do+  let fd = fdSocket sock+  _ <-+#if !defined(__HUGS__)+   throwSocketErrorIfMinus1RetryMayBlock "sendAncillary"+     (threadWaitWrite (fromIntegral fd)) $+#endif+     c_sendAncillary fd (fromIntegral level) (fromIntegral ty)+                        (fromIntegral flags) datum (fromIntegral len)+  return ()++recvAncillary :: Socket+              -> Int+              -> Int+              -> IO (Int,Int,Ptr a,Int)+recvAncillary sock flags len = do+  let fd = fdSocket sock+  alloca      $ \ ptr_len   ->+   alloca      $ \ ptr_lev   ->+    alloca      $ \ ptr_ty    ->+     alloca      $ \ ptr_pData -> do+      poke ptr_len (fromIntegral len)+      _ <- +#if !defined(__HUGS__)+        throwSocketErrorIfMinus1RetryMayBlock "recvAncillary" +            (threadWaitRead (fromIntegral fd)) $+#endif+            c_recvAncillary fd ptr_lev ptr_ty (fromIntegral flags) ptr_pData ptr_len+      rcvlen <- fromIntegral `liftM` peek ptr_len+      lev <- fromIntegral `liftM` peek ptr_lev+      ty  <- fromIntegral `liftM` peek ptr_ty+      pD  <- peek ptr_pData+      return (lev,ty,pD, rcvlen)+foreign import ccall SAFE_ON_WIN "sendAncillary"+  c_sendAncillary :: CInt -> CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt++foreign import ccall SAFE_ON_WIN "recvAncillary"+  c_recvAncillary :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr (Ptr a) -> Ptr CInt -> IO CInt++foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt+foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt++#endif+++{-+A calling sequence table for the main functions is shown in the table below.++\begin{figure}[h]+\begin{center}+\begin{tabular}{|l|c|c|c|c|c|c|c|}d+\hline+{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\+\hline+{\bf Precedes} & & & & & & & \\+\hline +socket &        &         &            &        &        &      & \\+\hline+connect & +     &         &            &        &        &      & \\+\hline+bindSocket & +  &         &            &        &        &      & \\+\hline+listen &        &         & +          &        &        &      & \\+\hline+accept &        &         &            &  +     &        &      & \\+\hline+read   &        &   +     &            &  +     &  +     &  +   & + \\+\hline+write  &        &   +     &            &  +     &  +     &  +   & + \\+\hline+\end{tabular}+\caption{Sequence Table for Major functions of Socket}+\label{tab:api-seq}+\end{center}+\end{figure}+-}++-- ---------------------------------------------------------------------------+-- OS Dependent Definitions+    +unpackFamily    :: CInt -> Family+packFamily      :: Family -> CInt++packSocketType  :: SocketType -> CInt+unpackSocketType:: CInt -> SocketType++------ ------+                        +packFamily f = case f of+        AF_UNSPEC -> #const AF_UNSPEC+#ifdef AF_UNIX+        AF_UNIX -> #const AF_UNIX+#endif+#ifdef AF_INET+        AF_INET -> #const AF_INET+#endif+#ifdef AF_INET6+        AF_INET6 -> #const AF_INET6+#endif+#ifdef AF_IMPLINK+        AF_IMPLINK -> #const AF_IMPLINK+#endif+#ifdef AF_PUP+        AF_PUP -> #const AF_PUP+#endif+#ifdef AF_CHAOS+        AF_CHAOS -> #const AF_CHAOS+#endif+#ifdef AF_NS+        AF_NS -> #const AF_NS+#endif+#ifdef AF_NBS+        AF_NBS -> #const AF_NBS+#endif+#ifdef AF_ECMA+        AF_ECMA -> #const AF_ECMA+#endif+#ifdef AF_DATAKIT+        AF_DATAKIT -> #const AF_DATAKIT+#endif+#ifdef AF_CCITT+        AF_CCITT -> #const AF_CCITT+#endif+#ifdef AF_SNA+        AF_SNA -> #const AF_SNA+#endif+#ifdef AF_DECnet+        AF_DECnet -> #const AF_DECnet+#endif+#ifdef AF_DLI+        AF_DLI -> #const AF_DLI+#endif+#ifdef AF_LAT+        AF_LAT -> #const AF_LAT+#endif+#ifdef AF_HYLINK+        AF_HYLINK -> #const AF_HYLINK+#endif+#ifdef AF_APPLETALK+        AF_APPLETALK -> #const AF_APPLETALK+#endif+#ifdef AF_ROUTE+        AF_ROUTE -> #const AF_ROUTE+#endif+#ifdef AF_NETBIOS+        AF_NETBIOS -> #const AF_NETBIOS+#endif+#ifdef AF_NIT+        AF_NIT -> #const AF_NIT+#endif+#ifdef AF_802+        AF_802 -> #const AF_802+#endif+#ifdef AF_ISO+        AF_ISO -> #const AF_ISO+#endif+#ifdef AF_OSI+        AF_OSI -> #const AF_OSI+#endif+#ifdef AF_NETMAN+        AF_NETMAN -> #const AF_NETMAN+#endif+#ifdef AF_X25+        AF_X25 -> #const AF_X25+#endif+#ifdef AF_AX25+        AF_AX25 -> #const AF_AX25+#endif+#ifdef AF_OSINET+        AF_OSINET -> #const AF_OSINET+#endif+#ifdef AF_GOSSIP+        AF_GOSSIP -> #const AF_GOSSIP+#endif+#ifdef AF_IPX+        AF_IPX -> #const AF_IPX+#endif+#ifdef Pseudo_AF_XTP+        Pseudo_AF_XTP -> #const Pseudo_AF_XTP+#endif+#ifdef AF_CTF+        AF_CTF -> #const AF_CTF+#endif+#ifdef AF_WAN+        AF_WAN -> #const AF_WAN+#endif+#ifdef AF_SDL+        AF_SDL -> #const AF_SDL+#endif+#ifdef AF_NETWARE+        AF_NETWARE -> #const AF_NETWARE +#endif+#ifdef AF_NDD+        AF_NDD -> #const AF_NDD         +#endif+#ifdef AF_INTF+        AF_INTF -> #const AF_INTF+#endif+#ifdef AF_COIP+        AF_COIP -> #const AF_COIP+#endif+#ifdef AF_CNT+        AF_CNT -> #const AF_CNT+#endif+#ifdef Pseudo_AF_RTIP+        Pseudo_AF_RTIP -> #const Pseudo_AF_RTIP+#endif+#ifdef Pseudo_AF_PIP+        Pseudo_AF_PIP -> #const Pseudo_AF_PIP+#endif+#ifdef AF_SIP+        AF_SIP -> #const AF_SIP+#endif+#ifdef AF_ISDN+        AF_ISDN -> #const AF_ISDN+#endif+#ifdef Pseudo_AF_KEY+        Pseudo_AF_KEY -> #const Pseudo_AF_KEY+#endif+#ifdef AF_NATM+        AF_NATM -> #const AF_NATM+#endif+#ifdef AF_ARP+        AF_ARP -> #const AF_ARP+#endif+#ifdef Pseudo_AF_HDRCMPLT+        Pseudo_AF_HDRCMPLT -> #const Pseudo_AF_HDRCMPLT+#endif+#ifdef AF_ENCAP+        AF_ENCAP -> #const AF_ENCAP +#endif+#ifdef AF_LINK+        AF_LINK -> #const AF_LINK+#endif+#ifdef AF_RAW+        AF_RAW -> #const AF_RAW+#endif+#ifdef AF_RIF+        AF_RIF -> #const AF_RIF+#endif+#ifdef AF_NETROM+        AF_NETROM -> #const AF_NETROM+#endif+#ifdef AF_BRIDGE+        AF_BRIDGE -> #const AF_BRIDGE+#endif+#ifdef AF_ATMPVC+        AF_ATMPVC -> #const AF_ATMPVC+#endif+#ifdef AF_ROSE+        AF_ROSE -> #const AF_ROSE+#endif+#ifdef AF_NETBEUI+        AF_NETBEUI -> #const AF_NETBEUI+#endif+#ifdef AF_SECURITY+        AF_SECURITY -> #const AF_SECURITY+#endif+#ifdef AF_PACKET+        AF_PACKET -> #const AF_PACKET+#endif+#ifdef AF_ASH+        AF_ASH -> #const AF_ASH+#endif+#ifdef AF_ECONET+        AF_ECONET -> #const AF_ECONET+#endif+#ifdef AF_ATMSVC+        AF_ATMSVC -> #const AF_ATMSVC+#endif+#ifdef AF_IRDA+        AF_IRDA -> #const AF_IRDA+#endif+#ifdef AF_PPPOX+        AF_PPPOX -> #const AF_PPPOX+#endif+#ifdef AF_WANPIPE+        AF_WANPIPE -> #const AF_WANPIPE+#endif+#ifdef AF_BLUETOOTH+        AF_BLUETOOTH -> #const AF_BLUETOOTH+#endif++--------- ----------++unpackFamily f = case f of+        (#const AF_UNSPEC) -> AF_UNSPEC+#ifdef AF_UNIX+        (#const AF_UNIX) -> AF_UNIX+#endif+#ifdef AF_INET+        (#const AF_INET) -> AF_INET+#endif+#ifdef AF_INET6+        (#const AF_INET6) -> AF_INET6+#endif+#ifdef AF_IMPLINK+        (#const AF_IMPLINK) -> AF_IMPLINK+#endif+#ifdef AF_PUP+        (#const AF_PUP) -> AF_PUP+#endif+#ifdef AF_CHAOS+        (#const AF_CHAOS) -> AF_CHAOS+#endif+#ifdef AF_NS+        (#const AF_NS) -> AF_NS+#endif+#ifdef AF_NBS+        (#const AF_NBS) -> AF_NBS+#endif+#ifdef AF_ECMA+        (#const AF_ECMA) -> AF_ECMA+#endif+#ifdef AF_DATAKIT+        (#const AF_DATAKIT) -> AF_DATAKIT+#endif+#ifdef AF_CCITT+        (#const AF_CCITT) -> AF_CCITT+#endif+#ifdef AF_SNA+        (#const AF_SNA) -> AF_SNA+#endif+#ifdef AF_DECnet+        (#const AF_DECnet) -> AF_DECnet+#endif+#ifdef AF_DLI+        (#const AF_DLI) -> AF_DLI+#endif+#ifdef AF_LAT+        (#const AF_LAT) -> AF_LAT+#endif+#ifdef AF_HYLINK+        (#const AF_HYLINK) -> AF_HYLINK+#endif+#ifdef AF_APPLETALK+        (#const AF_APPLETALK) -> AF_APPLETALK+#endif+#ifdef AF_ROUTE+        (#const AF_ROUTE) -> AF_ROUTE+#endif+#ifdef AF_NETBIOS+        (#const AF_NETBIOS) -> AF_NETBIOS+#endif+#ifdef AF_NIT+        (#const AF_NIT) -> AF_NIT+#endif+#ifdef AF_802+        (#const AF_802) -> AF_802+#endif+#ifdef AF_ISO+        (#const AF_ISO) -> AF_ISO+#endif+#ifdef AF_OSI+# if (!defined(AF_ISO)) || (defined(AF_ISO) && (AF_ISO != AF_OSI))+        (#const AF_OSI) -> AF_OSI+# endif+#endif+#ifdef AF_NETMAN+        (#const AF_NETMAN) -> AF_NETMAN+#endif+#ifdef AF_X25+        (#const AF_X25) -> AF_X25+#endif+#ifdef AF_AX25+        (#const AF_AX25) -> AF_AX25+#endif+#ifdef AF_OSINET+        (#const AF_OSINET) -> AF_OSINET+#endif+#ifdef AF_GOSSIP+        (#const AF_GOSSIP) -> AF_GOSSIP+#endif+#if defined(AF_IPX) && (!defined(AF_NS) || AF_NS != AF_IPX)+        (#const AF_IPX) -> AF_IPX+#endif+#ifdef Pseudo_AF_XTP+        (#const Pseudo_AF_XTP) -> Pseudo_AF_XTP+#endif+#ifdef AF_CTF+        (#const AF_CTF) -> AF_CTF+#endif+#ifdef AF_WAN+        (#const AF_WAN) -> AF_WAN+#endif+#ifdef AF_SDL+        (#const AF_SDL) -> AF_SDL+#endif+#ifdef AF_NETWARE+        (#const AF_NETWARE) -> AF_NETWARE       +#endif+#ifdef AF_NDD+        (#const AF_NDD) -> AF_NDD               +#endif+#ifdef AF_INTF+        (#const AF_INTF) -> AF_INTF+#endif+#ifdef AF_COIP+        (#const AF_COIP) -> AF_COIP+#endif+#ifdef AF_CNT+        (#const AF_CNT) -> AF_CNT+#endif+#ifdef Pseudo_AF_RTIP+        (#const Pseudo_AF_RTIP) -> Pseudo_AF_RTIP+#endif+#ifdef Pseudo_AF_PIP+        (#const Pseudo_AF_PIP) -> Pseudo_AF_PIP+#endif+#ifdef AF_SIP+        (#const AF_SIP) -> AF_SIP+#endif+#ifdef AF_ISDN+        (#const AF_ISDN) -> AF_ISDN+#endif+#ifdef Pseudo_AF_KEY+        (#const Pseudo_AF_KEY) -> Pseudo_AF_KEY+#endif+#ifdef AF_NATM+        (#const AF_NATM) -> AF_NATM+#endif+#ifdef AF_ARP+        (#const AF_ARP) -> AF_ARP+#endif+#ifdef Pseudo_AF_HDRCMPLT+        (#const Pseudo_AF_HDRCMPLT) -> Pseudo_AF_HDRCMPLT+#endif+#ifdef AF_ENCAP+        (#const AF_ENCAP) -> AF_ENCAP +#endif+#ifdef AF_LINK+        (#const AF_LINK) -> AF_LINK+#endif+#ifdef AF_RAW+        (#const AF_RAW) -> AF_RAW+#endif+#ifdef AF_RIF+        (#const AF_RIF) -> AF_RIF+#endif+#ifdef AF_NETROM+        (#const AF_NETROM) -> AF_NETROM+#endif+#ifdef AF_BRIDGE+        (#const AF_BRIDGE) -> AF_BRIDGE+#endif+#ifdef AF_ATMPVC+        (#const AF_ATMPVC) -> AF_ATMPVC+#endif+#ifdef AF_ROSE+        (#const AF_ROSE) -> AF_ROSE+#endif+#ifdef AF_NETBEUI+        (#const AF_NETBEUI) -> AF_NETBEUI+#endif+#ifdef AF_SECURITY+        (#const AF_SECURITY) -> AF_SECURITY+#endif+#ifdef AF_PACKET+        (#const AF_PACKET) -> AF_PACKET+#endif+#ifdef AF_ASH+        (#const AF_ASH) -> AF_ASH+#endif+#ifdef AF_ECONET+        (#const AF_ECONET) -> AF_ECONET+#endif+#ifdef AF_ATMSVC+        (#const AF_ATMSVC) -> AF_ATMSVC+#endif+#ifdef AF_IRDA+        (#const AF_IRDA) -> AF_IRDA+#endif+#ifdef AF_PPPOX+        (#const AF_PPPOX) -> AF_PPPOX+#endif+#ifdef AF_WANPIPE+        (#const AF_WANPIPE) -> AF_WANPIPE+#endif+#ifdef AF_BLUETOOTH+        (#const AF_BLUETOOTH) -> AF_BLUETOOTH+#endif+        unknown -> error ("Network.Socket.unpackFamily: unknown address " +++                          "family " ++ show unknown)++-- Socket Types.++-- | Socket Types.+--+-- This data type might have different constructors depending on what is+-- supported by the operating system.+data SocketType+        = NoSocketType+#ifdef SOCK_STREAM+        | Stream +#endif+#ifdef SOCK_DGRAM+        | Datagram+#endif+#ifdef SOCK_RAW+        | Raw +#endif+#ifdef SOCK_RDM+        | RDM +#endif+#ifdef SOCK_SEQPACKET+        | SeqPacket+#endif+        deriving (Eq, Ord, Read, Show, Typeable)++packSocketType stype = case stype of+        NoSocketType -> 0+#ifdef SOCK_STREAM+        Stream -> #const SOCK_STREAM+#endif+#ifdef SOCK_DGRAM+        Datagram -> #const SOCK_DGRAM+#endif+#ifdef SOCK_RAW+        Raw -> #const SOCK_RAW+#endif+#ifdef SOCK_RDM+        RDM -> #const SOCK_RDM+#endif+#ifdef SOCK_SEQPACKET+        SeqPacket -> #const SOCK_SEQPACKET+#endif++unpackSocketType t = case t of+        0 -> NoSocketType+#ifdef SOCK_STREAM+        (#const SOCK_STREAM) -> Stream+#endif+#ifdef SOCK_DGRAM+        (#const SOCK_DGRAM) -> Datagram+#endif+#ifdef SOCK_RAW+        (#const SOCK_RAW) -> Raw+#endif+#ifdef SOCK_RDM+        (#const SOCK_RDM) -> RDM+#endif+#ifdef SOCK_SEQPACKET+        (#const SOCK_SEQPACKET) -> SeqPacket+#endif+        _ -> NoSocketType++-- ---------------------------------------------------------------------------+-- Utility Functions++aNY_PORT :: PortNumber +aNY_PORT = 0++-- | The IPv4 wild card address.++iNADDR_ANY :: HostAddress+iNADDR_ANY = htonl (#const INADDR_ANY)++#if defined(IPV6_SOCKET_SUPPORT)+-- | The IPv6 wild card address.++iN6ADDR_ANY :: HostAddress6+iN6ADDR_ANY = (0, 0, 0, 0)+#endif++sOMAXCONN :: Int+sOMAXCONN = #const SOMAXCONN++sOL_SOCKET :: Int+sOL_SOCKET = #const SOL_SOCKET++#ifdef SCM_RIGHTS+sCM_RIGHTS :: Int+sCM_RIGHTS = #const SCM_RIGHTS+#endif++maxListenQueue :: Int+maxListenQueue = sOMAXCONN++-- -----------------------------------------------------------------------------++data ShutdownCmd + = ShutdownReceive+ | ShutdownSend+ | ShutdownBoth+ deriving Typeable++sdownCmdToInt :: ShutdownCmd -> CInt+sdownCmdToInt ShutdownReceive = 0+sdownCmdToInt ShutdownSend    = 1+sdownCmdToInt ShutdownBoth    = 2++-- | Shut down one or both halves of the connection, depending on the+-- second argument to the function.  If the second argument is+-- 'ShutdownReceive', further receives are disallowed.  If it is+-- 'ShutdownSend', further sends are disallowed.  If it is+-- 'ShutdownBoth', further sends and receives are disallowed.+shutdown :: Socket -> ShutdownCmd -> IO ()+shutdown (MkSocket s _ _ _ _) stype = do+  throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))+  return ()++-- -----------------------------------------------------------------------------++-- | Close the socket.  All future operations on the socket object+-- will fail.  The remote end will receive no more data (after queued+-- data is flushed).+sClose   :: Socket -> IO ()+sClose (MkSocket s _ _ _ socketStatus) = do + modifyMVar_ socketStatus $ \ status ->+   case status of+     ConvertedToHandle ->+         ioError (userError ("sClose: converted to a Handle, use hClose instead"))+     Closed ->+         return status+     _ -> closeFdWith (close . fromIntegral) (fromIntegral s) >> return Closed++-- -----------------------------------------------------------------------------++sIsConnected :: Socket -> IO Bool+sIsConnected (MkSocket _ _ _ _ status) = do+    value <- readMVar status+    return (value == Connected) ++-- -----------------------------------------------------------------------------+-- Socket Predicates++sIsBound :: Socket -> IO Bool+sIsBound (MkSocket _ _ _ _ status) = do+    value <- readMVar status+    return (value == Bound)     ++sIsListening :: Socket -> IO Bool+sIsListening (MkSocket _ _ _  _ status) = do+    value <- readMVar status+    return (value == Listening) ++sIsReadable  :: Socket -> IO Bool+sIsReadable (MkSocket _ _ _ _ status) = do+    value <- readMVar status+    return (value == Listening || value == Connected)++sIsWritable  :: Socket -> IO Bool+sIsWritable = sIsReadable -- sort of.++sIsAcceptable :: Socket -> IO Bool+#if defined(DOMAIN_SOCKET_SUPPORT)+sIsAcceptable (MkSocket _ AF_UNIX x _ status)+    | x == Stream || x == SeqPacket = do+        value <- readMVar status+        return (value == Connected || value == Bound || value == Listening)+sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False+#endif+sIsAcceptable (MkSocket _ _ _ _ status) = do+    value <- readMVar status+    return (value == Connected || value == Listening)+    +-- -----------------------------------------------------------------------------+-- Internet address manipulation routines:++inet_addr :: String -> IO HostAddress+inet_addr ipstr = do+   withCString ipstr $ \str -> do+   had <- c_inet_addr str+   if had == -1+    then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))+    else return had  -- network byte order++inet_ntoa :: HostAddress -> IO String+inet_ntoa haddr = do+  pstr <- c_inet_ntoa haddr+  peekCString pstr++-- | Turns a Socket into an 'Handle'. By default, the new handle is+-- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering.+--+-- Note that since a 'Handle' is automatically closed by a finalizer+-- when it is no longer referenced, you should avoid doing any more+-- operations on the 'Socket' after calling 'socketToHandle'.  To+-- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose'+-- on the 'Handle'.++#ifndef __PARALLEL_HASKELL__+socketToHandle :: Socket -> IOMode -> IO Handle+socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do+ modifyMVar socketStatus $ \ status ->+    if status == ConvertedToHandle+        then ioError (userError ("socketToHandle: already a Handle"))+        else do+# if __GLASGOW_HASKELL__ >= 611+    h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}+# elif __GLASGOW_HASKELL__ >= 608+    h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}+# elif __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 608+    h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}+# elif defined(__HUGS__)+    h <- openFd (fromIntegral fd) True{-is a socket-} mode True{-bin-}+# endif+    return (ConvertedToHandle, h)+#else+socketToHandle (MkSocket s family stype protocol status) m =+  error "socketToHandle not implemented in a parallel setup"+#endif++-- | Pack a list of values into a bitmask.  The possible mappings from+-- value to bit-to-set are given as the first argument.  We assume+-- that each value can cause exactly one bit to be set; unpackBits will+-- break if this property is not true.++packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b++packBits mapping xs = foldl' pack 0 mapping+    where pack acc (k, v) | k `elem` xs = acc .|. v+                          | otherwise   = acc++-- | Unpack a bitmask into a list of values.++unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]++-- Be permissive and ignore unknown bit values. At least on OS X,+-- getaddrinfo returns an ai_flags field with bits set that have no+-- entry in <netdb.h>.+unpackBits [] _    = []+unpackBits ((k,v):xs) r+    | r .&. v /= 0 = k : unpackBits xs (r .&. complement v)+    | otherwise    = unpackBits xs r++-----------------------------------------------------------------------------+-- Address and service lookups++#if defined(IPV6_SOCKET_SUPPORT)++-- | Flags that control the querying behaviour of 'getAddrInfo'.+data AddrInfoFlag+    = AI_ADDRCONFIG+    | AI_ALL+    | AI_CANONNAME+    | AI_NUMERICHOST+    | AI_NUMERICSERV+    | AI_PASSIVE+    | AI_V4MAPPED+    deriving (Eq, Read, Show, Typeable)++aiFlagMapping :: [(AddrInfoFlag, CInt)]++aiFlagMapping =+    [+#if HAVE_DECL_AI_ADDRCONFIG+     (AI_ADDRCONFIG, #const AI_ADDRCONFIG),+#else+     (AI_ADDRCONFIG, 0),+#endif+#if HAVE_DECL_AI_ALL+     (AI_ALL, #const AI_ALL),+#else+     (AI_ALL, 0),+#endif+     (AI_CANONNAME, #const AI_CANONNAME),+     (AI_NUMERICHOST, #const AI_NUMERICHOST),+#if HAVE_DECL_AI_NUMERICSERV+     (AI_NUMERICSERV, #const AI_NUMERICSERV),+#else+     (AI_NUMERICSERV, 0),+#endif+     (AI_PASSIVE, #const AI_PASSIVE),+#if HAVE_DECL_AI_V4MAPPED+     (AI_V4MAPPED, #const AI_V4MAPPED)+#else+     (AI_V4MAPPED, 0)+#endif+    ]++-- | Indicate whether the given 'AddrInfoFlag' will have any effect on+-- this system.+addrInfoFlagImplemented :: AddrInfoFlag -> Bool+addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0++data AddrInfo =+    AddrInfo {+        addrFlags :: [AddrInfoFlag],+        addrFamily :: Family,+        addrSocketType :: SocketType,+        addrProtocol :: ProtocolNumber,+        addrAddress :: SockAddr,+        addrCanonName :: Maybe String+        }+    deriving (Eq, Show, Typeable)++instance Storable AddrInfo where+    sizeOf    _ = #const sizeof(struct addrinfo)+    alignment _ = alignment (undefined :: CInt)++    peek p = do+        ai_flags <- (#peek struct addrinfo, ai_flags) p+        ai_family <- (#peek struct addrinfo, ai_family) p+        ai_socktype <- (#peek struct addrinfo, ai_socktype) p+        ai_protocol <- (#peek struct addrinfo, ai_protocol) p+        ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr+        ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p++        ai_canonname <- if ai_canonname_ptr == nullPtr+                        then return Nothing+                        else liftM Just $ peekCString ai_canonname_ptr+                             +        return (AddrInfo+                {+                 addrFlags = unpackBits aiFlagMapping ai_flags,+                 addrFamily = unpackFamily ai_family,+                 addrSocketType = unpackSocketType ai_socktype,+                 addrProtocol = ai_protocol,+                 addrAddress = ai_addr,+                 addrCanonName = ai_canonname+                })++    poke p (AddrInfo flags family socketType protocol _ _) = do+        (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)+        (#poke struct addrinfo, ai_family) p (packFamily family)+        (#poke struct addrinfo, ai_socktype) p (packSocketType socketType)+        (#poke struct addrinfo, ai_protocol) p protocol++        -- stuff below is probably not needed, but let's zero it for safety++        (#poke struct addrinfo, ai_addrlen) p (0::CSize)+        (#poke struct addrinfo, ai_addr) p nullPtr+        (#poke struct addrinfo, ai_canonname) p nullPtr+        (#poke struct addrinfo, ai_next) p nullPtr++data NameInfoFlag+    = NI_DGRAM+    | NI_NAMEREQD+    | NI_NOFQDN+    | NI_NUMERICHOST+    | NI_NUMERICSERV+    deriving (Eq, Read, Show, Typeable)++niFlagMapping :: [(NameInfoFlag, CInt)]++niFlagMapping = [(NI_DGRAM, #const NI_DGRAM),+                 (NI_NAMEREQD, #const NI_NAMEREQD),+                 (NI_NOFQDN, #const NI_NOFQDN),+                 (NI_NUMERICHOST, #const NI_NUMERICHOST),+                 (NI_NUMERICSERV, #const NI_NUMERICSERV)]++-- | Default hints for address lookup with 'getAddrInfo'.  The values+-- of the 'addrAddress' and 'addrCanonName' fields are 'undefined',+-- and are never inspected by 'getAddrInfo'.++defaultHints :: AddrInfo++defaultHints = AddrInfo {+                         addrFlags = [],+                         addrFamily = AF_UNSPEC,+                         addrSocketType = NoSocketType,+                         addrProtocol = defaultProtocol,+                         addrAddress = undefined,+                         addrCanonName = undefined+                        }++-- | Resolve a host or service name to one or more addresses.+-- The 'AddrInfo' values that this function returns contain 'SockAddr'+-- values that you can pass directly to 'connect' or+-- 'bindSocket'.+--+-- This function is protocol independent.  It can return both IPv4 and+-- IPv6 address information.+--+-- The 'AddrInfo' argument specifies the preferred query behaviour,+-- socket options, or protocol.  You can override these conveniently+-- using Haskell's record update syntax on 'defaultHints', for example+-- as follows:+--+-- @+--   myHints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }+-- @+--+-- Values for 'addrFlags' control query behaviour.  The supported+-- flags are as follows:+--+--   [@AI_PASSIVE@] If no 'HostName' value is provided, the network+--     address in each 'SockAddr'+--     will be left as a "wild card", i.e. as either 'iNADDR_ANY'+--     or 'iN6ADDR_ANY'.  This is useful for server applications that+--     will accept connections from any client.+--+--   [@AI_CANONNAME@] The 'addrCanonName' field of the first returned+--     'AddrInfo' will contain the "canonical name" of the host.+--+--   [@AI_NUMERICHOST@] The 'HostName' argument /must/ be a numeric+--     address in string form, and network name lookups will not be+--     attempted.+-- +-- /Note/: Although the following flags are required by RFC 3493, they+-- may not have an effect on all platforms, because the underlying+-- network stack may not support them.  To see whether a flag from the+-- list below will have any effect, call 'addrInfoFlagImplemented'.+--+--   [@AI_NUMERICSERV@] The 'ServiceName' argument /must/ be a port+--     number in string form, and service name lookups will not be+--     attempted.+--+--   [@AI_ADDRCONFIG@] The list of returned 'AddrInfo' values will+--     only contain IPv4 addresses if the local system has at least+--     one IPv4 interface configured, and likewise for IPv6.+--+--   [@AI_V4MAPPED@] If an IPv6 lookup is performed, and no IPv6+--     addresses are found, IPv6-mapped IPv4 addresses will be+--     returned.+--+--   [@AI_ALL@] If 'AI_ALL' is specified, return all matching IPv6 and+--     IPv4 addresses.  Otherwise, this flag has no effect.+--     +-- You must provide a 'Just' value for at least one of the 'HostName'+-- or 'ServiceName' arguments.  'HostName' can be either a numeric+-- network address (dotted quad for IPv4, colon-separated hex for+-- IPv6) or a hostname.  In the latter case, its addresses will be+-- looked up unless 'AI_NUMERICHOST' is specified as a hint.  If you+-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as+-- a hint, network addresses in the result will contain the address of+-- the loopback interface.+--+-- If the query fails, this function throws an IO exception instead of+-- returning an empty list.  Otherwise, it returns a non-empty list+-- of 'AddrInfo' values.+--+-- There are several reasons why a query might result in several+-- values.  For example, the queried-for host could be multihomed, or+-- the service might be available via several protocols.+--+-- Note: the order of arguments is slightly different to that defined+-- for @getaddrinfo@ in RFC 2553.  The 'AddrInfo' parameter comes first+-- to make partial application easier.+--+-- Example:+-- @+--   let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }+--   addrs <- getAddrInfo (Just hints) (Just "www.haskell.org") (Just "http")+--   let addr = head addrs+--   sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+--   connect sock (addrAddress addr)+-- @++getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol+            -> Maybe HostName -- ^ host name to look up+            -> Maybe ServiceName -- ^ service name to look up+            -> IO [AddrInfo] -- ^ resolved addresses, with "best" first++getAddrInfo hints node service =+  maybeWith withCString node $ \c_node ->+    maybeWith withCString service $ \c_service ->+      maybeWith with hints $ \c_hints ->+        alloca $ \ptr_ptr_addrs -> do+          ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs+          case ret of+            0 -> do ptr_addrs <- peek ptr_ptr_addrs+                    ais <- followAddrInfo ptr_addrs+                    c_freeaddrinfo ptr_addrs+                    return ais+            _ -> do err <- gai_strerror ret+                    ioError (ioeSetErrorString+                             (mkIOError NoSuchThing "getAddrInfo" Nothing+                              Nothing) err)++followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo]++followAddrInfo ptr_ai | ptr_ai == nullPtr = return []+                      | otherwise = do+    a <- peek ptr_ai+    as <- (#peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo+    return (a:as)++foreign import ccall safe "hsnet_getaddrinfo"+    c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo)+                  -> IO CInt++foreign import ccall safe "hsnet_freeaddrinfo"+    c_freeaddrinfo :: Ptr AddrInfo -> IO ()++gai_strerror :: CInt -> IO String++#ifdef HAVE_GAI_STRERROR+gai_strerror n = c_gai_strerror n >>= peekCString++foreign import ccall safe "gai_strerror"+    c_gai_strerror :: CInt -> IO CString+#else+gai_strerror n = return ("error " ++ show n)+#endif++withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a+withCStringIf False _ f = f 0 nullPtr+withCStringIf True n f = allocaBytes n (f (fromIntegral n))+                    +-- | Resolve an address to a host or service name.+-- This function is protocol independent.+--+-- The list of 'NameInfoFlag' values controls query behaviour.  The+-- supported flags are as follows:+--+--   [@NI_NOFQDN@] If a host is local, return only the+--     hostname part of the FQDN.+--+--   [@NI_NUMERICHOST@] The name of the host is not+--     looked up.  Instead, a numeric representation of the host's+--     address is returned.  For an IPv4 address, this will be a+--     dotted-quad string.  For IPv6, it will be colon-separated+--     hexadecimal.+--+--   [@NI_NUMERICSERV@] The name of the service is not+--     looked up.  Instead, a numeric representation of the+--     service is returned.+--+--   [@NI_NAMEREQD@] If the hostname cannot be looked up, an IO error+--     is thrown.+--+--   [@NI_DGRAM@] Resolve a datagram-based service name.  This is+--     required only for the few protocols that have different port+--     numbers for their datagram-based versions than for their+--     stream-based versions.+--+-- Hostname and service name lookups can be expensive.  You can+-- specify which lookups to perform via the two 'Bool' arguments.  If+-- one of these is 'False', the corresponding value in the returned+-- tuple will be 'Nothing', and no lookup will be performed.+--+-- If a host or service's name cannot be looked up, then the numeric+-- form of the address or service will be returned.+--+-- If the query fails, this function throws an IO exception.+--+-- Example:+-- @+--   (hostName, _) <- getNameInfo [] True False myAddress+-- @++getNameInfo :: [NameInfoFlag] -- ^ flags to control lookup behaviour+            -> Bool -- ^ whether to look up a hostname+            -> Bool -- ^ whether to look up a service name+            -> SockAddr -- ^ the address to look up+            -> IO (Maybe HostName, Maybe ServiceName)++getNameInfo flags doHost doService addr =+  withCStringIf doHost (#const NI_MAXHOST) $ \c_hostlen c_host ->+    withCStringIf doService (#const NI_MAXSERV) $ \c_servlen c_serv -> do+      withSockAddr addr $ \ptr_addr sz -> do+        ret <- c_getnameinfo ptr_addr (fromIntegral sz) c_host c_hostlen+                             c_serv c_servlen (packBits niFlagMapping flags)+        case ret of+          0 -> do+            let peekIf doIf c_val = if doIf+                                     then liftM Just $ peekCString c_val+                                     else return Nothing+            host <- peekIf doHost c_host+            serv <- peekIf doService c_serv+            return (host, serv)+          _ -> do err <- gai_strerror ret+                  ioError (ioeSetErrorString+                           (mkIOError NoSuchThing "getNameInfo" Nothing +                            Nothing) err)++foreign import ccall safe "hsnet_getnameinfo"+    c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString+                  -> CSize -> CInt -> IO CInt+#endif++mkInvalidRecvArgError :: String -> IOError+mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError+#ifdef __GLASGOW_HASKELL__+                                    InvalidArgument+#else+                                    IllegalOperation+#endif+                                    loc Nothing Nothing) "non-positive length"++mkEOFError :: String -> IOError+mkEOFError loc = ioeSetErrorString (mkIOError EOF loc Nothing Nothing) "end of file"++-- ---------------------------------------------------------------------------+-- foreign imports from the C library++foreign import ccall unsafe "my_inet_ntoa"+  c_inet_ntoa :: HostAddress -> IO (Ptr CChar)++foreign import CALLCONV unsafe "inet_addr"+  c_inet_addr :: Ptr CChar -> IO HostAddress++foreign import CALLCONV unsafe "shutdown"+  c_shutdown :: CInt -> CInt -> IO CInt ++close :: CInt -> IO ()+close fd = throwErrnoIfMinus1Retry_ "Network.Socket.close" $ c_close fd++#if !defined(WITH_WINSOCK)+foreign import ccall unsafe "close"+  c_close :: CInt -> IO CInt+#else+foreign import stdcall unsafe "closesocket"+  c_close :: CInt -> IO CInt+#endif++foreign import CALLCONV unsafe "socket"+  c_socket :: CInt -> CInt -> CInt -> IO CInt+foreign import CALLCONV unsafe "bind"+  c_bind :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt+foreign import CALLCONV unsafe "connect"+  c_connect :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt+foreign import CALLCONV unsafe "accept"+  c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt+foreign import CALLCONV unsafe "listen"+  c_listen :: CInt -> CInt -> IO CInt++#if defined(mingw32_HOST_OS) && defined(__GLASGOW_HASKELL__)+foreign import CALLCONV safe "accept"+  c_accept_safe :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt++foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool+#endif++foreign import CALLCONV unsafe "send"+  c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt+foreign import CALLCONV SAFE_ON_WIN "sendto"+  c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> CInt -> IO CInt+foreign import CALLCONV unsafe "recv"+  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt+foreign import CALLCONV SAFE_ON_WIN "recvfrom"+  c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt+foreign import CALLCONV unsafe "getpeername"+  c_getpeername :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt+foreign import CALLCONV unsafe "getsockname"+  c_getsockname :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt++foreign import CALLCONV unsafe "getsockopt"+  c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt+foreign import CALLCONV unsafe "setsockopt"+  c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+ Network/Socket/ByteString.hsc view
@@ -0,0 +1,383 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++#include "HsNet.h"++-- |+-- Module      : Network.Socket.ByteString+-- Copyright   : (c) Johan Tibell 2007-2010+-- License     : BSD-style+--+-- Maintainer  : johan.tibell@gmail.com+-- Stability   : stable+-- Portability : portable+--+-- This module provides access to the BSD /socket/ interface.  This+-- module is generally more efficient than the 'String' based network+-- functions in 'Network.Socket'.  For detailed documentation, consult+-- your favorite POSIX socket reference. All functions communicate+-- failures by converting the error number to 'System.IO.IOError'.+--+-- This module is made to be imported with 'Network.Socket' like so:+--+-- > import Network.Socket hiding (send, sendTo, recv, recvFrom)+-- > import Network.Socket.ByteString+--+module Network.Socket.ByteString+    ( +    -- * Send data to a socket+      send+    , sendAll+    , sendTo+    , sendAllTo++    -- ** Vectored I/O+    -- $vectored+    , sendMany+    , sendManyTo++    -- * Receive data from a socket+    , recv+    , recvFrom++    -- * Example+    -- $example+    ) where++import Control.Monad (liftM, when)+import Data.ByteString (ByteString)+import Data.ByteString.Internal (createAndTrim)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.Word (Word8)+#if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types (CInt(..))+#else+import Foreign.C.Types (CInt)+#endif+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr, castPtr)+import Network.Socket (SockAddr, Socket(..), sendBufTo, recvBufFrom)++import qualified Data.ByteString as B++import Network.Socket.ByteString.Internal++#if !defined(mingw32_HOST_OS)+import Control.Monad (zipWithM_)+import Foreign.C.Types (CChar)+# if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types (CSize(..))+# else+import Foreign.C.Types (CSize)+# endif+import Foreign.Marshal.Array (allocaArray)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock,+                                withSockAddr)++import Network.Socket.ByteString.IOVec (IOVec(..))+import Network.Socket.ByteString.MsgHdr (MsgHdr(..))++#  if defined(__GLASGOW_HASKELL__)+import GHC.Conc (threadWaitRead, threadWaitWrite)+#  endif+#else+#  if defined(__GLASGOW_HASKELL__)+#    if __GLASGOW_HASKELL__ >= 611+import GHC.IO.FD+#    else+import GHC.Handle (readRawBufferPtr, writeRawBufferPtr)+#    endif+#  endif+#endif++#if !defined(mingw32_HOST_OS)+foreign import CALLCONV unsafe "send"+  c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt+foreign import CALLCONV unsafe "recv"+  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt+#endif++-- ----------------------------------------------------------------------------+-- Sending++-- | Send data to the socket.  The socket must be connected to a+-- remote socket.  Returns the number of bytes sent. Applications are+-- responsible for ensuring that all data has been sent.+send :: Socket      -- ^ Connected socket+     -> ByteString  -- ^ Data to send+     -> IO Int      -- ^ Number of bytes sent+send (MkSocket s _ _ _ _) xs =+    unsafeUseAsCStringLen xs $ \(str, len) ->+    liftM fromIntegral $+#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)+#  if __GLASGOW_HASKELL__ >= 611+        writeRawBufferPtr "Network.Socket.ByteString.send"+        (FD s 1) (castPtr str) 0 (fromIntegral len)+#  else+        writeRawBufferPtr "Network.Socket.ByteString.send"+        (fromIntegral s) True str 0 (fromIntegral len)+#  endif+#else+#  if !defined(__HUGS__)+        throwSocketErrorIfMinus1RetryMayBlock "send"+        (threadWaitWrite (fromIntegral s)) $+#  endif+        c_send s str (fromIntegral len) 0+#endif++-- | Send data to the socket.  The socket must be connected to a+-- remote socket.  Unlike 'send', this function continues to send data+-- until either all data has been sent or an error occurs.  On error,+-- an exception is raised, and there is no way to determine how much+-- data, if any, was successfully sent.+sendAll :: Socket      -- ^ Connected socket+        -> ByteString  -- ^ Data to send+        -> IO ()+sendAll sock bs = do+    sent <- send sock bs+    when (sent < B.length bs) $ sendAll sock (B.drop sent bs)++-- | Send data to the socket.  The recipient can be specified+-- explicitly, so the socket need not be in a connected state.+-- Returns the number of bytes sent. Applications are responsible for+-- ensuring that all data has been sent.+sendTo :: Socket      -- ^ Socket+       -> ByteString  -- ^ Data to send+       -> SockAddr    -- ^ Recipient address+       -> IO Int      -- ^ Number of bytes sent+sendTo sock xs addr =+    unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo sock str len addr++-- | Send data to the socket. The recipient can be specified+-- explicitly, so the socket need not be in a connected state.  Unlike+-- 'sendTo', this function continues to send data until either all+-- data has been sent or an error occurs.  On error, an exception is+-- raised, and there is no way to determine how much data, if any, was+-- successfully sent.+sendAllTo :: Socket      -- ^ Socket+          -> ByteString  -- ^ Data to send+          -> SockAddr    -- ^ Recipient address+          -> IO ()+sendAllTo sock xs addr = do+    sent <- sendTo sock xs addr+    when (sent < B.length xs) $ sendAllTo sock (B.drop sent xs) addr++-- ----------------------------------------------------------------------------+-- ** Vectored I/O++-- $vectored+--+-- Vectored I\/O, also known as scatter\/gather I\/O, allows multiple+-- data segments to be sent using a single system call, without first+-- concatenating the segments.  For example, given a list of+-- @ByteString@s, @xs@,+--+-- > sendMany sock xs+--+-- is equivalent to+--+-- > sendAll sock (concat xs)+--+-- but potentially more efficient.+--+-- Vectored I\/O are often useful when implementing network protocols+-- that, for example, group data into segments consisting of one or+-- more fixed-length headers followed by a variable-length body.++-- | Send data to the socket.  The socket must be in a connected+-- state.  The data is sent as if the parts have been concatenated.+-- This function continues to send data until either all data has been+-- sent or an error occurs.  On error, an exception is raised, and+-- there is no way to determine how much data, if any, was+-- successfully sent.+sendMany :: Socket        -- ^ Connected socket+         -> [ByteString]  -- ^ Data to send+         -> IO ()+#if !defined(mingw32_HOST_OS)+sendMany sock@(MkSocket fd _ _ _ _) cs = do+    sent <- sendManyInner+    when (sent < totalLength cs) $ sendMany sock (remainingChunks sent cs)+  where+    sendManyInner =+      liftM fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) ->+          throwSocketErrorIfMinus1RetryMayBlock "writev"+              (threadWaitWrite (fromIntegral fd)) $+              c_writev (fromIntegral fd) iovsPtr (fromIntegral iovsLen)+#else+sendMany sock = sendAll sock . B.concat+#endif++-- | Send data to the socket.  The recipient can be specified+-- explicitly, so the socket need not be in a connected state.  The+-- data is sent as if the parts have been concatenated.  This function+-- continues to send data until either all data has been sent or an+-- error occurs.  On error, an exception is raised, and there is no+-- way to determine how much data, if any, was successfully sent.+sendManyTo :: Socket        -- ^ Socket+           -> [ByteString]  -- ^ Data to send+           -> SockAddr      -- ^ Recipient address+           -> IO ()+#if !defined(mingw32_HOST_OS)+sendManyTo sock@(MkSocket fd _ _ _ _) cs addr = do+    sent <- liftM fromIntegral sendManyToInner+    when (sent < totalLength cs) $ sendManyTo sock (remainingChunks sent cs) addr+  where+    sendManyToInner =+      withSockAddr addr $ \addrPtr addrSize ->+        withIOVec cs $ \(iovsPtr, iovsLen) -> do+          let msgHdr = MsgHdr+                addrPtr (fromIntegral addrSize)+                iovsPtr (fromIntegral iovsLen)+          with msgHdr $ \msgHdrPtr ->+            throwSocketErrorIfMinus1RetryMayBlock "sendmsg"+              (threadWaitWrite (fromIntegral fd)) $+              c_sendmsg (fromIntegral fd) msgHdrPtr 0+#else+sendManyTo sock cs = sendAllTo sock (B.concat cs)+#endif++-- ----------------------------------------------------------------------------+-- Receiving++-- | Receive data from the socket.  The socket must be in a connected+-- state.  This function may return fewer bytes than specified.  If+-- the message is longer than the specified length, it may be+-- discarded depending on the type of socket.  This function may block+-- until a message arrives.+--+-- Considering hardware and network realities, the maximum number of bytes to+-- receive should be a small power of 2, e.g., 4096.+--+-- For TCP sockets, a zero length return value means the peer has+-- closed its half side of the connection.+recv :: Socket         -- ^ Connected socket+     -> Int            -- ^ Maximum number of bytes to receive+     -> IO ByteString  -- ^ Data received+recv (MkSocket s _ _ _ _) nbytes+    | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv")+    | otherwise  = createAndTrim nbytes $ recvInner s nbytes++recvInner :: CInt -> Int -> Ptr Word8 -> IO Int+recvInner s nbytes ptr =+    fmap fromIntegral $+#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)+#  if __GLASGOW_HASKELL__ >= 611+        readRawBufferPtr "Network.Socket.ByteString.recv" (FD s 1) ptr 0 (fromIntegral nbytes)+#  else+        readRawBufferPtr "Network.Socket.ByteString.recv" (fromIntegral s)+        True (castPtr ptr) 0 (fromIntegral nbytes)+#  endif+#else+#  if !defined(__HUGS__)+        throwSocketErrorIfMinus1RetryMayBlock "recv"+        (threadWaitRead (fromIntegral s)) $+#  endif+        c_recv s (castPtr ptr) (fromIntegral nbytes) 0+#endif++-- | Receive data from the socket.  The socket need not be in a+-- connected state.  Returns @(bytes, address)@ where @bytes@ is a+-- 'ByteString' representing the data received and @address@ is a+-- 'SockAddr' representing the address of the sending socket.+recvFrom :: Socket                     -- ^ Socket+         -> Int                        -- ^ Maximum number of bytes to receive+         -> IO (ByteString, SockAddr)  -- ^ Data received and sender address+recvFrom sock nbytes =+    allocaBytes nbytes $ \ptr -> do+        (len, sockaddr) <- recvBufFrom sock ptr nbytes+        str <- B.packCStringLen (ptr, len)+        return (str, sockaddr)++-- ----------------------------------------------------------------------------+-- Not exported++#if !defined(mingw32_HOST_OS)+-- | Suppose we try to transmit a list of chunks @cs@ via a gathering write+-- operation and find that @n@ bytes were sent. Then @remainingChunks n cs@ is+-- list of chunks remaining to be sent.+remainingChunks :: Int -> [ByteString] -> [ByteString]+remainingChunks _ [] = []+remainingChunks i (x:xs)+    | i < len        = B.drop i x : xs+    | otherwise      = let i' = i - len in i' `seq` remainingChunks i' xs+  where+    len = B.length x++-- | @totalLength cs@ is the sum of the lengths of the chunks in the list @cs@.+totalLength :: [ByteString] -> Int+totalLength = sum . map B.length++-- | @withIOVec cs f@ executes the computation @f@, passing as argument a pair+-- consisting of a pointer to a temporarily allocated array of pointers to+-- 'IOVec' made from @cs@ and the number of pointers (@length cs@).+-- /Unix only/.+withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a+withIOVec cs f =+    allocaArray csLen $ \aPtr -> do+        zipWithM_ pokeIov (ptrs aPtr) cs+        f (aPtr, csLen)+  where+    csLen = length cs+    ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec))+    pokeIov ptr s =+        unsafeUseAsCStringLen s $ \(sPtr, sLen) ->+        poke ptr $ IOVec sPtr (fromIntegral sLen)+#endif++-- ---------------------------------------------------------------------+-- Example++-- $example+--+-- Here are two minimal example programs using the TCP/IP protocol: a+-- server that echoes all data that it receives back (servicing only+-- one client) and a client using it.+--+-- > -- Echo server program+-- > module Main where+-- >+-- > import Control.Monad (unless)+-- > import Network.Socket hiding (recv)+-- > import qualified Data.ByteString as S+-- > import Network.Socket.ByteString (recv, sendAll)+-- >+-- > main :: IO ()+-- > main = withSocketsDo $+-- >     do addrinfos <- getAddrInfo+-- >                     (Just (defaultHints {addrFlags = [AI_PASSIVE]}))+-- >                     Nothing (Just "3000")+-- >        let serveraddr = head addrinfos+-- >        sock <- socket (addrFamily serveraddr) Stream defaultProtocol+-- >        bindSocket sock (addrAddress serveraddr)+-- >        listen sock 1+-- >        (conn, _) <- accept sock+-- >        talk conn+-- >        sClose conn+-- >        sClose sock+-- >+-- >     where+-- >       talk :: Socket -> IO ()+-- >       talk conn =+-- >           do msg <- recv conn 1024+-- >              unless (S.null msg) $ sendAll conn msg >> talk conn+--+-- > -- Echo client program+-- > module Main where+-- >+-- > import Network.Socket hiding (recv)+-- > import Network.Socket.ByteString (recv, sendAll)+-- > import qualified Data.ByteString.Char8 as C+-- >+-- > main :: IO ()+-- > main = withSocketsDo $+-- >     do addrinfos <- getAddrInfo Nothing (Just "") (Just "3000")+-- >        let serveraddr = head addrinfos+-- >        sock <- socket (addrFamily serveraddr) Stream defaultProtocol+-- >        connect sock (addrAddress serveraddr)+-- >        sendAll sock $ C.pack "Hello, world!"+-- >        msg <- recv sock 1024+-- >        sClose sock+-- >        putStr "Received "+-- >        C.putStrLn msg
+ Network/Socket/ByteString/IOVec.hsc view
@@ -0,0 +1,28 @@+-- | Support module for the POSIX writev system call.+module Network.Socket.ByteString.IOVec+    ( IOVec(..)+    ) where++import Foreign.C.Types (CChar, CInt, CSize)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..))++#include <sys/uio.h>++data IOVec = IOVec+    { iovBase :: Ptr CChar+    , iovLen  :: CSize+    }++instance Storable IOVec where+  sizeOf _    = (#const sizeof(struct iovec))+  alignment _ = alignment (undefined :: CInt)++  peek p = do+    base <- (#peek struct iovec, iov_base) p+    len  <- (#peek struct iovec, iov_len)  p+    return $ IOVec base len++  poke p iov = do+    (#poke struct iovec, iov_base) p (iovBase iov)+    (#poke struct iovec, iov_len)  p (iovLen  iov)
+ Network/Socket/ByteString/Internal.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-- |+-- Module      : Network.Socket.ByteString.Internal+-- Copyright   : (c) Johan Tibell 2007-2010+-- License     : BSD-style+--+-- Maintainer  : johan.tibell@gmail.com+-- Stability   : stable+-- Portability : portable+--+module Network.Socket.ByteString.Internal+    (+      mkInvalidRecvArgError+#if !defined(mingw32_HOST_OS)+    , c_writev+    , c_sendmsg+#endif+    ) where++import System.IO.Error (ioeSetErrorString, mkIOError)++#if !defined(mingw32_HOST_OS)+# if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types (CInt(..))+import System.Posix.Types (CSsize(..))+# else+import Foreign.C.Types (CInt)+import System.Posix.Types (CSsize)+# endif+import Foreign.Ptr (Ptr)++import Network.Socket.ByteString.IOVec (IOVec)+import Network.Socket.ByteString.MsgHdr (MsgHdr)+#endif++#ifdef __GLASGOW_HASKELL__+# if __GLASGOW_HASKELL__ < 611+import GHC.IOBase (IOErrorType(..))+# else+import GHC.IO.Exception (IOErrorType(..))+# endif+#elif __HUGS__+import Hugs.Prelude (IOErrorType(..))+#endif++mkInvalidRecvArgError :: String -> IOError+mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError+#ifdef __GLASGOW_HASKELL__+                                    InvalidArgument+#else+                                    IllegalOperation+#endif+                                    loc Nothing Nothing) "non-positive length"++#if !defined(mingw32_HOST_OS)+foreign import ccall unsafe "writev"+  c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize++foreign import ccall unsafe "sendmsg"+  c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CSsize+#endif
+ Network/Socket/ByteString/Lazy.hsc view
@@ -0,0 +1,154 @@+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface #-}++-- |+-- Module      : Network.Socket.ByteString.Lazy+-- Copyright   : (c) Bryan O'Sullivan 2009+-- License     : BSD-style+--+-- Maintainer  : bos@serpentine.com+-- Stability   : experimental+-- Portability : POSIX, GHC+--+-- This module provides access to the BSD /socket/ interface.  This+-- module is generally more efficient than the 'String' based network+-- functions in 'Network.Socket'.  For detailed documentation, consult+-- your favorite POSIX socket reference. All functions communicate+-- failures by converting the error number to 'System.IO.IOError'.+--+-- This module is made to be imported with 'Network.Socket' like so:+--+-- > import Network.Socket hiding (send, sendTo, recv, recvFrom)+-- > import Network.Socket.ByteString.Lazy+-- > import Prelude hiding (getContents)+--+module Network.Socket.ByteString.Lazy+    (+#if !defined(mingw32_HOST_OS)+    -- * Send data to a socket+      send+    , sendAll+    ,+#endif++    -- * Receive data from a socket+      getContents+    , recv+    ) where++import Control.Monad (liftM)+import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize)+import Data.Int (Int64)+import Network.Socket (Socket(..), ShutdownCmd(..), shutdown)+import Prelude hiding (getContents)+import System.IO.Unsafe (unsafeInterleaveIO)++import qualified Data.ByteString as S+import qualified Network.Socket.ByteString as N++#if !defined(mingw32_HOST_OS)+import Control.Monad (unless)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import Network.Socket.ByteString.IOVec (IOVec(IOVec))+import Network.Socket.ByteString.Internal (c_writev)+import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock)++import qualified Data.ByteString.Lazy as L++#  if defined(__GLASGOW_HASKELL__)+import GHC.Conc (threadWaitWrite)+#  endif+#endif++#if !defined(mingw32_HOST_OS)+-- -----------------------------------------------------------------------------+-- Sending++-- | Send data to the socket. The socket must be in a connected state.+-- Returns the number of bytes sent. Applications are responsible for+-- ensuring that all data has been sent.+--+-- Because a lazily generated 'ByteString' may be arbitrarily long,+-- this function caps the amount it will attempt to send at 4MB.  This+-- number is large (so it should not penalize performance on fast+-- networks), but not outrageously so (to avoid demanding lazily+-- computed data unnecessarily early).  Before being sent, the lazy+-- 'ByteString' will be converted to a list of strict 'ByteString's+-- with 'L.toChunks'; at most 1024 chunks will be sent.  /Unix only/.+send :: Socket      -- ^ Connected socket+     -> ByteString  -- ^ Data to send+     -> IO Int64    -- ^ Number of bytes sent+send (MkSocket fd _ _ _ _) s = do+  let cs  = take maxNumChunks (L.toChunks s)+      len = length cs+  liftM fromIntegral . allocaArray len $ \ptr ->+    withPokes cs ptr $ \niovs ->+#  if !defined(__HUGS__)+      throwSocketErrorIfMinus1RetryMayBlock "writev"+        (threadWaitWrite (fromIntegral fd)) $+#  endif+        c_writev (fromIntegral fd) ptr niovs+  where+    withPokes ss p f = loop ss p 0 0+      where loop (c:cs) q k !niovs+                | k < maxNumBytes =+                    unsafeUseAsCStringLen c $ \(ptr,len) -> do+                      poke q $ IOVec ptr (fromIntegral len)+                      loop cs (q `plusPtr` sizeOf (undefined :: IOVec))+                              (k + fromIntegral len) (niovs + 1)+                | otherwise = f niovs+            loop _ _ _ niovs = f niovs+    maxNumBytes  = 4194304 :: Int  -- maximum number of bytes to transmit in one system call+    maxNumChunks = 1024    :: Int  -- maximum number of chunks to transmit in one system call++-- | Send data to the socket.  The socket must be in a connected+-- state. This function continues to send data until either all data+-- has been sent or an error occurs.  If there is an error, an+-- exception is raised, and there is no way to determine how much data+-- was sent.  /Unix only/.+sendAll :: Socket      -- ^ Connected socket+        -> ByteString  -- ^ Data to send+        -> IO ()+sendAll sock bs = do+  sent <- send sock bs+  let bs' = L.drop sent bs+  unless (L.null bs') $ sendAll sock bs'+#endif++-- -----------------------------------------------------------------------------+-- Receiving++-- | Receive data from the socket.  The socket must be in a connected+-- state.  Data is received on demand, in chunks; each chunk will be+-- sized to reflect the amount of data received by individual 'recv'+-- calls.+--+-- All remaining data from the socket is consumed.  When there is no+-- more data to be received, the receiving side of the socket is shut+-- down.  If there is an error and an exception is thrown, the socket+-- is not shut down.+getContents :: Socket         -- ^ Connected socket+            -> IO ByteString  -- ^ Data received+getContents sock = loop where+  loop = unsafeInterleaveIO $ do+    s <- N.recv sock defaultChunkSize+    if S.null s+      then shutdown sock ShutdownReceive >> return Empty+      else Chunk s `liftM` loop++-- | Receive data from the socket.  The socket must be in a connected+-- state.  This function may return fewer bytes than specified.  If+-- the received data is longer than the specified length, it may be+-- discarded depending on the type of socket.  This function may block+-- until a message arrives.+--+-- If there is no more data to be received, returns an empty 'ByteString'.+recv :: Socket         -- ^ Connected socket+     -> Int64          -- ^ Maximum number of bytes to receive+     -> IO ByteString  -- ^ Data received+recv sock nbytes = chunk `liftM` N.recv sock (fromIntegral nbytes) where+  chunk k+    | S.null k  = Empty+    | otherwise = Chunk k Empty
+ Network/Socket/ByteString/MsgHdr.hsc view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}++-- | Support module for the POSIX 'sendmsg' system call.+module Network.Socket.ByteString.MsgHdr+    ( MsgHdr(..)+    ) where++#include <sys/types.h>+#include <sys/socket.h>++import Foreign.C.Types (CInt, CSize)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..))+import Network.Socket (SockAddr)+import Network.Socket.Internal (zeroMemory)++import Network.Socket.ByteString.IOVec (IOVec)++-- We don't use msg_control, msg_controllen, and msg_flags as these+-- don't exist on OpenSolaris.+data MsgHdr = MsgHdr+    { msgName    :: Ptr SockAddr+    , msgNameLen :: CSize+    , msgIov     :: Ptr IOVec+    , msgIovLen  :: CSize+    }++instance Storable MsgHdr where+  sizeOf _    = (#const sizeof(struct msghdr))+  alignment _ = alignment (undefined :: CInt)++  peek p = do+    name       <- (#peek struct msghdr, msg_name)       p+    nameLen    <- (#peek struct msghdr, msg_namelen)    p+    iov        <- (#peek struct msghdr, msg_iov)        p+    iovLen     <- (#peek struct msghdr, msg_iovlen)     p+    return $ MsgHdr name nameLen iov iovLen++  poke p mh = do+    -- We need to zero the msg_control, msg_controllen, and msg_flags+    -- fields, but they only exist on some platforms (e.g. not on+    -- Solaris).  Instead of using CPP, we zero the entire struct.+    zeroMemory p (#const sizeof(struct msghdr))+    (#poke struct msghdr, msg_name)       p (msgName       mh)+    (#poke struct msghdr, msg_namelen)    p (msgNameLen    mh)+    (#poke struct msghdr, msg_iov)        p (msgIov        mh)+    (#poke struct msghdr, msg_iovlen)     p (msgIovLen     mh)
+ Network/Socket/Internal.hsc view
@@ -0,0 +1,651 @@+{-# LANGUAGE CPP, FlexibleInstances, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.Socket.Internal+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/network/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A module containing semi-public 'Network.Socket' internals.+-- Modules which extend the 'Network.Socket' module will need to use+-- this module while ideally most users will be able to make do with+-- the public interface.+--+-----------------------------------------------------------------------------++#include "HsNet.h"++module Network.Socket.Internal+    (+    -- * Socket addresses+      HostAddress+#if defined(IPV6_SOCKET_SUPPORT)+    , HostAddress6+    , FlowInfo+    , ScopeID+#endif+    , PortNumber(..)+    , SockAddr(..)++    , peekSockAddr+    , pokeSockAddr+    , sizeOfSockAddr+    , sizeOfSockAddrByFamily+    , withSockAddr+    , withNewSockAddr++    -- * Protocol families+    , Family(..)++    -- * Socket error functions+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+    , c_getLastError+#endif+    , throwSocketError++    -- * Guards for socket operations that may fail+    , throwSocketErrorIfMinus1_+    , throwSocketErrorIfMinus1Retry+    , throwSocketErrorIfMinus1RetryMayBlock++    -- * Initialization+    , withSocketsDo++    -- * Low-level helpers+    , zeroMemory+    ) where++import Data.Bits ( (.|.), shiftL, shiftR )+import Data.Word ( Word8, Word16, Word32 )+import Data.Typeable (Typeable)+import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry,+                        throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_)+import Foreign.C.String ( castCharToCChar, peekCString )+#if __GLASGOW_HASKELL__ >= 703+import Foreign.C.Types ( CInt(..), CSize(..) )+#else+import Foreign.C.Types ( CInt, CSize )+#endif+import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.Marshal.Array ( pokeArray, pokeArray0 )+import Foreign.Ptr ( Ptr, castPtr, plusPtr )+import Foreign.Storable ( Storable(..) )++#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+import Control.Exception ( finally )+#  if __GLASGOW_HASKELL__+import GHC.IOBase ( IOErrorType(..) )+#  endif+import Foreign.C.Types ( CChar )+import System.IO.Error ( ioeSetErrorString, mkIOError )+#endif++------------------------------------------------------------------------++-- | Network byte order.+type HostAddress = Word32++#if defined(IPV6_SOCKET_SUPPORT)+-- | Host byte order.+type HostAddress6 = (Word32, Word32, Word32, Word32)++-- The peek32 and poke32 functions work around the fact that the RFCs+-- don't require 32-bit-wide address fields to be present.  We can+-- only portably rely on an 8-bit field, s6_addr.++s6_addr_offset :: Int+s6_addr_offset = (#offset struct in6_addr, s6_addr)++peek32 :: Ptr a -> Int -> IO Word32+peek32 p i0 = do+    let i' = i0 * 4+        peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8+        a `sl` i = fromIntegral a `shiftL` i+    a0 <- peekByte 0+    a1 <- peekByte 1+    a2 <- peekByte 2+    a3 <- peekByte 3+    return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0))++poke32 :: Ptr a -> Int -> Word32 -> IO ()+poke32 p i0 a = do+    let i' = i0 * 4+        pokeByte n = pokeByteOff p (s6_addr_offset + i' + n)+        x `sr` i = fromIntegral (x `shiftR` i) :: Word8+    pokeByte 0 (a `sr` 24)+    pokeByte 1 (a `sr` 16)+    pokeByte 2 (a `sr`  8)+    pokeByte 3 (a `sr`  0)++instance Storable HostAddress6 where+    sizeOf _    = (#const sizeof(struct in6_addr))+    alignment _ = alignment (undefined :: CInt)++    peek p = do+        a <- peek32 p 0+        b <- peek32 p 1+        c <- peek32 p 2+        d <- peek32 p 3+        return (a, b, c, d)++    poke p (a, b, c, d) = do+        poke32 p 0 a+        poke32 p 1 b+        poke32 p 2 c+        poke32 p 3 d+#endif++------------------------------------------------------------------------+-- Port Numbers+--+-- newtyped to prevent accidental use of sane-looking+-- port numbers that haven't actually been converted to+-- network-byte-order first.+--++newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Typeable)++------------------------------------------------------------------------+-- Socket addresses++-- The scheme used for addressing sockets is somewhat quirky. The+-- calls in the BSD socket API that need to know the socket address+-- all operate in terms of struct sockaddr, a `virtual' type of+-- socket address.++-- The Internet family of sockets are addressed as struct sockaddr_in,+-- so when calling functions that operate on struct sockaddr, we have+-- to type cast the Internet socket address into a struct sockaddr.+-- Instances of the structure for different families might *not* be+-- the same size. Same casting is required of other families of+-- sockets such as Xerox NS. Similarly for Unix domain sockets.++-- To represent these socket addresses in Haskell-land, we do what BSD+-- didn't do, and use a union/algebraic type for the different+-- families. Currently only Unix domain sockets and the Internet+-- families are supported.++#if defined(IPV6_SOCKET_SUPPORT)+type FlowInfo = Word32+type ScopeID = Word32+#endif++data SockAddr       -- C Names+  = SockAddrInet+    PortNumber  -- sin_port  (network byte order)+    HostAddress -- sin_addr  (ditto)+#if defined(IPV6_SOCKET_SUPPORT)+  | SockAddrInet6+        PortNumber      -- sin6_port (network byte order)+        FlowInfo        -- sin6_flowinfo (ditto)+        HostAddress6    -- sin6_addr (ditto)+        ScopeID         -- sin6_scope_id (ditto)+#endif+#if defined(DOMAIN_SOCKET_SUPPORT)+  | SockAddrUnix+        String          -- sun_path+#endif+  deriving (Eq, Typeable)++#if defined(WITH_WINSOCK) || defined(cygwin32_HOST_OS)+type CSaFamily = (#type unsigned short)+#elif defined(darwin_HOST_OS)+type CSaFamily = (#type u_char)+#else+type CSaFamily = (#type sa_family_t)+#endif++-- | Computes the storage requirements (in bytes) of the given+-- 'SockAddr'.  This function differs from 'Foreign.Storable.sizeOf'+-- in that the value of the argument /is/ used.+sizeOfSockAddr :: SockAddr -> Int+#if defined(DOMAIN_SOCKET_SUPPORT)+sizeOfSockAddr (SockAddrUnix path) =+    case path of+        '\0':_ -> (#const sizeof(sa_family_t)) + length path+        _      -> #const sizeof(struct sockaddr_un)+#endif+sizeOfSockAddr (SockAddrInet _ _) = #const sizeof(struct sockaddr_in)+#if defined(IPV6_SOCKET_SUPPORT)+sizeOfSockAddr (SockAddrInet6 _ _ _ _) = #const sizeof(struct sockaddr_in6)+#endif++-- | Computes the storage requirements (in bytes) required for a+-- 'SockAddr' with the given 'Family'.+sizeOfSockAddrByFamily :: Family -> Int+#if defined(DOMAIN_SOCKET_SUPPORT)+sizeOfSockAddrByFamily AF_UNIX  = #const sizeof(struct sockaddr_un)+#endif+#if defined(IPV6_SOCKET_SUPPORT)+sizeOfSockAddrByFamily AF_INET6 = #const sizeof(struct sockaddr_in6)+#endif+sizeOfSockAddrByFamily AF_INET  = #const sizeof(struct sockaddr_in)++-- | Use a 'SockAddr' with a function requiring a pointer to a+-- 'SockAddr' and the length of that 'SockAddr'.+withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a+withSockAddr addr f = do+    let sz = sizeOfSockAddr addr+    allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz++-- | Create a new 'SockAddr' for use with a function requiring a+-- pointer to a 'SockAddr' and the length of that 'SockAddr'.+withNewSockAddr :: Family -> (Ptr SockAddr -> Int -> IO a) -> IO a+withNewSockAddr family f = do+    let sz = sizeOfSockAddrByFamily family+    allocaBytes sz $ \ptr -> f ptr sz++-- We can't write an instance of 'Storable' for 'SockAddr' because+-- @sockaddr@ is a sum type of variable size but+-- 'Foreign.Storable.sizeOf' is required to be constant.++-- Note that on Darwin, the sockaddr structure must be zeroed before+-- use.++-- | Write the given 'SockAddr' to the given memory location.+pokeSockAddr :: Ptr a -> SockAddr -> IO ()+#if defined(DOMAIN_SOCKET_SUPPORT)+pokeSockAddr p (SockAddrUnix path) = do+#if defined(darwin_TARGET_OS)+    zeroMemory p (#const sizeof(struct sockaddr_un))+#endif+#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+    (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8)+#endif+    (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily)+    let pathC = map castCharToCChar path+        poker = case path of ('\0':_) -> pokeArray; _ -> pokeArray0 0+    poker ((#ptr struct sockaddr_un, sun_path) p) pathC+#endif+pokeSockAddr p (SockAddrInet (PortNum port) addr) = do+#if defined(darwin_TARGET_OS)+    zeroMemory p (#const sizeof(struct sockaddr_in))+#endif+#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+    (#poke struct sockaddr_in, sin_len) p ((#const sizeof(struct sockaddr_in)) :: Word8)+#endif+    (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily)+    (#poke struct sockaddr_in, sin_port) p port+    (#poke struct sockaddr_in, sin_addr) p addr+#if defined(IPV6_SOCKET_SUPPORT)+pokeSockAddr p (SockAddrInet6 (PortNum port) flow addr scope) = do+#if defined(darwin_TARGET_OS)+    zeroMemory p (#const sizeof(struct sockaddr_in6))+#endif+#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+    (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8)+#endif+    (#poke struct sockaddr_in6, sin6_family) p ((#const AF_INET6) :: CSaFamily)+    (#poke struct sockaddr_in6, sin6_port) p port+    (#poke struct sockaddr_in6, sin6_flowinfo) p flow+    (#poke struct sockaddr_in6, sin6_addr) p addr+    (#poke struct sockaddr_in6, sin6_scope_id) p scope+#endif++-- | Read a 'SockAddr' from the given memory location.+peekSockAddr :: Ptr SockAddr -> IO SockAddr+peekSockAddr p = do+  family <- (#peek struct sockaddr, sa_family) p+  case family :: CSaFamily of+#if defined(DOMAIN_SOCKET_SUPPORT)+    (#const AF_UNIX) -> do+        str <- peekCString ((#ptr struct sockaddr_un, sun_path) p)+        return (SockAddrUnix str)+#endif+    (#const AF_INET) -> do+        addr <- (#peek struct sockaddr_in, sin_addr) p+        port <- (#peek struct sockaddr_in, sin_port) p+        return (SockAddrInet (PortNum port) addr)+#if defined(IPV6_SOCKET_SUPPORT)+    (#const AF_INET6) -> do+        port <- (#peek struct sockaddr_in6, sin6_port) p+        flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p+        addr <- (#peek struct sockaddr_in6, sin6_addr) p+        scope <- (#peek struct sockaddr_in6, sin6_scope_id) p+        return (SockAddrInet6 (PortNum port) flow addr scope)+#endif++------------------------------------------------------------------------+-- Protocol Families.++-- | This data type might have different constructors depending on+-- what is supported by the operating system.+data Family+    = AF_UNSPEC           -- unspecified+#ifdef AF_UNIX+    | AF_UNIX             -- local to host (pipes, portals+#endif+#ifdef AF_INET+    | AF_INET             -- internetwork: UDP, TCP, etc+#endif+#ifdef AF_INET6+    | AF_INET6            -- Internet Protocol version 6+#endif+#ifdef AF_IMPLINK+    | AF_IMPLINK          -- arpanet imp addresses+#endif+#ifdef AF_PUP+    | AF_PUP              -- pup protocols: e.g. BSP+#endif+#ifdef AF_CHAOS+    | AF_CHAOS            -- mit CHAOS protocols+#endif+#ifdef AF_NS+    | AF_NS               -- XEROX NS protocols+#endif+#ifdef AF_NBS+    | AF_NBS              -- nbs protocols+#endif+#ifdef AF_ECMA+    | AF_ECMA             -- european computer manufacturers+#endif+#ifdef AF_DATAKIT+    | AF_DATAKIT          -- datakit protocols+#endif+#ifdef AF_CCITT+    | AF_CCITT            -- CCITT protocols, X.25 etc+#endif+#ifdef AF_SNA+    | AF_SNA              -- IBM SNA+#endif+#ifdef AF_DECnet+    | AF_DECnet           -- DECnet+#endif+#ifdef AF_DLI+    | AF_DLI              -- Direct data link interface+#endif+#ifdef AF_LAT+    | AF_LAT              -- LAT+#endif+#ifdef AF_HYLINK+    | AF_HYLINK           -- NSC Hyperchannel+#endif+#ifdef AF_APPLETALK+    | AF_APPLETALK        -- Apple Talk+#endif+#ifdef AF_ROUTE+    | AF_ROUTE            -- Internal Routing Protocol+#endif+#ifdef AF_NETBIOS+    | AF_NETBIOS          -- NetBios-style addresses+#endif+#ifdef AF_NIT+    | AF_NIT              -- Network Interface Tap+#endif+#ifdef AF_802+    | AF_802              -- IEEE 802.2, also ISO 8802+#endif+#ifdef AF_ISO+    | AF_ISO              -- ISO protocols+#endif+#ifdef AF_OSI+    | AF_OSI              -- umbrella of all families used by OSI+#endif+#ifdef AF_NETMAN+    | AF_NETMAN           -- DNA Network Management+#endif+#ifdef AF_X25+    | AF_X25              -- CCITT X.25+#endif+#ifdef AF_AX25+    | AF_AX25+#endif+#ifdef AF_OSINET+    | AF_OSINET           -- AFI+#endif+#ifdef AF_GOSSIP+    | AF_GOSSIP           -- US Government OSI+#endif+#ifdef AF_IPX+    | AF_IPX              -- Novell Internet Protocol+#endif+#ifdef Pseudo_AF_XTP+    | Pseudo_AF_XTP       -- eXpress Transfer Protocol (no AF)+#endif+#ifdef AF_CTF+    | AF_CTF              -- Common Trace Facility+#endif+#ifdef AF_WAN+    | AF_WAN              -- Wide Area Network protocols+#endif+#ifdef AF_SDL+    | AF_SDL              -- SGI Data Link for DLPI+#endif+#ifdef AF_NETWARE+    | AF_NETWARE+#endif+#ifdef AF_NDD+    | AF_NDD+#endif+#ifdef AF_INTF+    | AF_INTF             -- Debugging use only+#endif+#ifdef AF_COIP+    | AF_COIP             -- connection-oriented IP, aka ST II+#endif+#ifdef AF_CNT+    | AF_CNT              -- Computer Network Technology+#endif+#ifdef Pseudo_AF_RTIP+    | Pseudo_AF_RTIP      -- Help Identify RTIP packets+#endif+#ifdef Pseudo_AF_PIP+    | Pseudo_AF_PIP       -- Help Identify PIP packets+#endif+#ifdef AF_SIP+    | AF_SIP              -- Simple Internet Protocol+#endif+#ifdef AF_ISDN+    | AF_ISDN             -- Integrated Services Digital Network+#endif+#ifdef Pseudo_AF_KEY+    | Pseudo_AF_KEY       -- Internal key-management function+#endif+#ifdef AF_NATM+    | AF_NATM             -- native ATM access+#endif+#ifdef AF_ARP+    | AF_ARP              -- (rev.) addr. res. prot. (RFC 826)+#endif+#ifdef Pseudo_AF_HDRCMPLT+    | Pseudo_AF_HDRCMPLT  -- Used by BPF to not rewrite hdrs in iface output+#endif+#ifdef AF_ENCAP+    | AF_ENCAP+#endif+#ifdef AF_LINK+    | AF_LINK             -- Link layer interface+#endif+#ifdef AF_RAW+    | AF_RAW              -- Link layer interface+#endif+#ifdef AF_RIF+    | AF_RIF              -- raw interface+#endif+#ifdef AF_NETROM+    | AF_NETROM           -- Amateur radio NetROM+#endif+#ifdef AF_BRIDGE+    | AF_BRIDGE           -- multiprotocol bridge+#endif+#ifdef AF_ATMPVC+    | AF_ATMPVC           -- ATM PVCs+#endif+#ifdef AF_ROSE+    | AF_ROSE             -- Amateur Radio X.25 PLP+#endif+#ifdef AF_NETBEUI+    | AF_NETBEUI          -- 802.2LLC+#endif+#ifdef AF_SECURITY+    | AF_SECURITY         -- Security callback pseudo AF+#endif+#ifdef AF_PACKET+    | AF_PACKET           -- Packet family+#endif+#ifdef AF_ASH+    | AF_ASH              -- Ash+#endif+#ifdef AF_ECONET+    | AF_ECONET           -- Acorn Econet+#endif+#ifdef AF_ATMSVC+    | AF_ATMSVC           -- ATM SVCs+#endif+#ifdef AF_IRDA+    | AF_IRDA             -- IRDA sockets+#endif+#ifdef AF_PPPOX+    | AF_PPPOX            -- PPPoX sockets+#endif+#ifdef AF_WANPIPE+    | AF_WANPIPE          -- Wanpipe API sockets+#endif+#ifdef AF_BLUETOOTH+    | AF_BLUETOOTH        -- bluetooth sockets+#endif+      deriving (Eq, Ord, Read, Show)++-- ---------------------------------------------------------------------+-- Guards for socket operations that may fail++-- | Throw an 'IOError' corresponding to the current socket error.+throwSocketError :: String  -- ^ textual description of the error location+                 -> IO a++-- | Throw an 'IOError' corresponding to the current socket error if+-- the IO action returns a result of @-1@.  Discards the result of the+-- IO action after error handling.+throwSocketErrorIfMinus1_+    :: (Eq a, Num a)+    => String  -- ^ textual description of the location+    -> IO a    -- ^ the 'IO' operation to be executed+    -> IO ()++{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-}++-- | Throw an 'IOError' corresponding to the current socket error if+-- the IO action returns a result of @-1@, but retries in case of an+-- interrupted operation.+throwSocketErrorIfMinus1Retry+    :: (Eq a, Num a)+    => String  -- ^ textual description of the location+    -> IO a    -- ^ the 'IO' operation to be executed+    -> IO a++{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-}++-- | Throw an 'IOError' corresponding to the current socket error if+-- the IO action returns a result of @-1@, but retries in case of an+-- interrupted operation.  Checks for operations that would block and+-- executes an alternative action before retrying in that case.+throwSocketErrorIfMinus1RetryMayBlock+    :: (Eq a, Num a)+    => String  -- ^ textual description of the location+    -> IO b    -- ^ action to execute before retrying if an+               --   immediate retry would block+    -> IO a    -- ^ the 'IO' operation to be executed+    -> IO a++{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock+        :: String -> IO b -> IO CInt -> IO CInt #-}++#if defined(__GLASGOW_HASKELL__) && (!defined(HAVE_WINSOCK2_H) || defined(cygwin32_HOST_OS))++throwSocketErrorIfMinus1RetryMayBlock name on_block act =+    throwErrnoIfMinus1RetryMayBlock name act on_block++throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry++throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_++throwSocketError = throwErrno++#else++throwSocketErrorIfMinus1RetryMayBlock name _ act+  = throwSocketErrorIfMinus1Retry name act++throwSocketErrorIfMinus1_ name act = do+  throwSocketErrorIfMinus1Retry name act+  return ()++# if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+throwSocketErrorIfMinus1Retry name act = do+  r <- act+  if (r == -1)+   then do+    rc   <- c_getLastError+    case rc of+      10093 -> do -- WSANOTINITIALISED+        withSocketsDo (return ())+        r <- act+        if (r == -1)+           then throwSocketError name+           else return r+      _ -> throwSocketError name+   else return r++throwSocketError name = do+    rc <- c_getLastError+    pstr <- c_getWSError rc+    str  <- peekCString pstr+#  if __GLASGOW_HASKELL__+    ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str)+#  else+    ioError (userError (name ++ ": socket error - " ++ str))+#  endif++foreign import CALLCONV unsafe "WSAGetLastError"+  c_getLastError :: IO CInt++foreign import ccall unsafe "getWSErrorDescr"+  c_getWSError :: CInt -> IO (Ptr CChar)+++# else+throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry+throwSocketError = throwErrno+# endif+#endif /* __GLASGOW_HASKELL */++-- ---------------------------------------------------------------------------+-- WinSock support++{-| On Windows operating systems, the networking subsystem has to be+initialised using 'withSocketsDo' before any networking operations can+be used.  eg.++> main = withSocketsDo $ do {...}++Although this is only strictly necessary on Windows platforms, it is+harmless on other platforms, so for portability it is good practice to+use it all the time.+-}+withSocketsDo :: IO a -> IO a+#if !defined(WITH_WINSOCK)+withSocketsDo x = x+#else+withSocketsDo act = do+    x <- initWinSock+    if x /= 0+       then ioError (userError "Failed to initialise WinSock")+       else act `finally` shutdownWinSock++foreign import ccall unsafe "initWinSock" initWinSock :: IO Int+foreign import ccall unsafe "shutdownWinSock" shutdownWinSock :: IO ()++#endif++------------------------------------------------------------------------+-- Helper functions++foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()++-- | Zero a structure.+zeroMemory :: Ptr a -> CSize -> IO ()+zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes)
+ Network/Stream.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.Stream+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- An library for creating abstract streams. Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Removed unnecessary import statements.+--      - Moved Debug code to StreamDebugger.hs+--      - Moved Socket-related code to StreamSocket.hs.+--+-- * Changes by Simon Foster:+--      - Split Network.HTTPmodule up into to separate+--        Network.[Stream,TCP,HTTP] modules+-----------------------------------------------------------------------------+module Network.Stream+   ( Stream(..)+   , ConnError(..)+   , Result+   , bindE+   , fmapE++   , failParse -- :: String -> Result a+   , failWith  -- :: ConnError -> Result a+   , failMisc  -- :: String -> Result a+   ) where++import Control.Monad.Error++data ConnError + = ErrorReset + | ErrorClosed+ | ErrorParse String+ | ErrorMisc String+   deriving(Show,Eq)++instance Error ConnError where+  noMsg = strMsg "unknown error"+  strMsg x = ErrorMisc x++-- in GHC 7.0 the Monad instance for Error no longer+-- uses fail x = Left (strMsg x). failMisc is therefore+-- used instead.+failMisc :: String -> Result a+failMisc x = failWith (strMsg x)++failParse :: String -> Result a+failParse x = failWith (ErrorParse x)++failWith :: ConnError -> Result a+failWith x = Left x++bindE :: Result a -> (a -> Result b) -> Result b+bindE (Left e)  _ = Left e+bindE (Right v) f = f v++fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b)+fmapE f a = do+ x <- a+ case x of+   Left  e -> return (Left e)+   Right r -> return (f r) +  +-- | This is the type returned by many exported network functions.+type Result a = Either ConnError   {- error  -}+                       a           {- result -}++-- | Streams should make layering of TLS protocol easier in future,+-- they allow reading/writing to files etc for debugging,+-- they allow use of protocols other than TCP/IP+-- and they allow customisation.+--+-- Instances of this class should not trim+-- the input in any way, e.g. leave LF on line+-- endings etc. Unless that is exactly the behaviour+-- you want from your twisted instances ;)+class Stream x where +    readLine   :: x -> IO (Result String)+    readBlock  :: x -> Int -> IO (Result String)+    writeBlock :: x -> String -> IO (Result ())+    close      :: x -> IO ()+    closeOnEnd :: x -> Bool -> IO ()+      -- ^ True => shutdown the connection when response has been read / end-of-stream+      --           has been reached.
+ Network/StreamDebugger.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.StreamDebugger+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Implements debugging of @Stream@s.  Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Created.  Made minor formatting changes.+--      +-----------------------------------------------------------------------------+module Network.StreamDebugger+   ( StreamDebugger+   , debugStream+   , debugByteStream+   ) where++import Network.Stream (Stream(..))+import System.IO+   ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile,+     hSetBuffering, BufferMode(NoBuffering)+   )+import Network.TCP ( HandleStream, HStream, +       		     StreamHooks(..), setStreamHooks, getStreamHooks )++-- | Allows stream logging.  Refer to 'debugStream' below.+data StreamDebugger x+   = Dbg Handle x++instance (Stream x) => Stream (StreamDebugger x) where+    readBlock (Dbg h x) n =+        do val <- readBlock x n+           hPutStrLn h ("--readBlock " ++ show n)+	   hPutStrLn h (show val)+           return val+    readLine (Dbg h x) =+        do val <- readLine x+           hPutStrLn h ("--readLine")+	   hPutStrLn h (show val)+           return val+    writeBlock (Dbg h x) str =+        do val <- writeBlock x str+           hPutStrLn h ("--writeBlock" ++ show str)+	   hPutStrLn h (show val)+           return val+    close (Dbg h x) =+        do hPutStrLn h "--closing..."+           hFlush h+           close x+           hPutStrLn h "--closed."+           hClose h+    closeOnEnd (Dbg h x) f =+        do hPutStrLn h ("--close-on-end.." ++ show f)+           hFlush h +           closeOnEnd x f++-- | Wraps a stream with logging I\/O.+--   The first argument is a filename which is opened in @AppendMode@.+debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)+debugStream file stream = +    do h <- openFile file AppendMode+       hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")+       return (Dbg h stream)++debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty)+debugByteStream file stream = do+   sh <- getStreamHooks stream +   case sh of+     Just h +      | hook_name h == file -> return stream -- reuse the stream hooks.+     _ -> do+       h <- openFile file AppendMode+       hSetBuffering h NoBuffering+       hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")+       setStreamHooks stream (debugStreamHooks h file)+       return stream++debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty+debugStreamHooks h nm = +  StreamHooks+    { hook_readBlock = \ toStr n val -> do+       let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+       hPutStrLn h ("--readBlock " ++ show n)+       hPutStrLn h (either show show eval)+    , hook_readLine = \ toStr val -> do+	   let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+           hPutStrLn h ("--readLine")+	   hPutStrLn h (either show show eval)+    , hook_writeBlock = \ toStr str val -> do+           hPutStrLn h ("--writeBlock " ++ show val)+	   hPutStrLn h (toStr str)+    , hook_close = do+           hPutStrLn h "--closing..."+           hFlush h+           hClose h+    , hook_name = nm+    }
+ Network/StreamSocket.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.StreamSocket+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies in import statements.+--      - Created separate module for instance Stream Socket.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      +-----------------------------------------------------------------------------+module Network.StreamSocket+   ( handleSocketError+   , myrecv+   ) where++import Network.Stream+   ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result+   )+import Network.Socket+   ( Socket, getSocketOption, shutdown, send, recv, sClose+   , ShutdownCmd(ShutdownBoth), SocketOption(SoError)+   )++import Network.HTTP.Base ( catchIO )+import Control.Monad (liftM)+import Control.Exception as Exception (IOException)+import System.IO.Error (catch, isEOFError)++-- | Exception handler for socket operations.+handleSocketError :: Socket -> IOException -> IO (Result a)+handleSocketError sk e =+    do se <- getSocketOption sk SoError+       case se of+          0     -> ioError e+          10054 -> return $ Left ErrorReset  -- reset+          _     -> return $ Left $ ErrorMisc $ show se++myrecv :: Socket -> Int -> IO String+myrecv sock len =+    let handler e = if isEOFError e then return [] else ioError e+        in System.IO.Error.catch (recv sock len) handler++instance Stream Socket where+    readBlock sk n    = readBlockSocket sk n+    readLine sk       = readLineSocket sk+    writeBlock sk str = writeBlockSocket sk str+    close sk          = do+        -- This slams closed the connection (which is considered rude for TCP\/IP)+         shutdown sk ShutdownBoth+         sClose sk+    closeOnEnd _sk _  = return () -- can't really deal with this, so do run the risk of leaking sockets here.++readBlockSocket :: Socket -> Int -> IO (Result String)+readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk)+  where+   fn x = do { str <- myrecv sk x+             ; let len = length str+             ; if len < x+                then ( fn (x-len) >>= \more -> return (str++more) )+                else return str+             }++-- Use of the following function is discouraged.+-- The function reads in one character at a time, +-- which causes many calls to the kernel recv()+-- hence causes many context switches.+readLineSocket :: Socket -> IO (Result String)+readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk)+  where+   fn str = do+     c <- myrecv sk 1 -- like eating through a straw.+     if null c || c == "\n"+      then return (reverse str++c)+      else fn (head c:str)+    +writeBlockSocket :: Socket -> String -> IO (Result ())+writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk)+  where+   fn [] = return ()+   fn x  = send sk x >>= \i -> fn (drop i x)+
+ Network/TCP.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.TCP+-- Copyright   :  See LICENSE file+-- License     :  BSD+--+-- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Some utility functions for working with the Haskell @network@ package. Mostly+-- for internal use by the @Network.HTTP@ code, but +--      +-----------------------------------------------------------------------------+module Network.TCP+   ( Connection+   , EndPoint(..)+   , openTCPPort+   , isConnectedTo++   , openTCPConnection+   , socketConnection+   , isTCPConnectedTo+   +   , HandleStream+   , HStream(..)+   +   , StreamHooks(..)+   , nullHooks+   , setStreamHooks+   , getStreamHooks+   , hstreamToConnection++   ) where++import Network.BSD (getHostByName, hostAddresses)+import Network.Socket+   ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive)+   , SocketType(Stream), inet_addr, connect+   , shutdown, ShutdownCmd(..)+   , sClose, setSocketOption, getPeerName+   , socket, Family(AF_INET)+   )+import qualified Network.Stream as Stream+   ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) )+import Network.Stream+   ( ConnError(..)+   , Result+   , failWith+   , failMisc+   )+import Network.BufferType++import Network.HTTP.Base ( catchIO )+import Network.Socket ( socketToHandle )++import Data.Char  ( toLower )+import Data.Word  ( Word8 )+import Control.Concurrent+import Control.Monad ( liftM, when )+import System.IO ( Handle, hFlush, IOMode(..), hClose )+import System.IO.Error ( isEOFError )++import qualified Data.ByteString      as Strict+import qualified Data.ByteString.Lazy as Lazy++-----------------------------------------------------------------+------------------ TCP Connections ------------------------------+-----------------------------------------------------------------++-- | The 'Connection' newtype is a wrapper that allows us to make+-- connections an instance of the Stream class, without GHC extensions.+-- While this looks sort of like a generic reference to the transport+-- layer it is actually TCP specific, which can be seen in the+-- implementation of the 'Stream Connection' instance.+newtype Connection = Connection (HandleStream String)++newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)}++data EndPoint = EndPoint { epHost :: String, epPort :: Int }++instance Eq EndPoint where+   EndPoint host1 port1 == EndPoint host2 port2 =+     map toLower host1 == map toLower host2 && port1 == port2++data Conn a + = MkConn { connSock      :: ! Socket+	  , connHandle    :: Handle+          , connBuffer    :: BufferOp a+	  , connInput     :: Maybe a+          , connEndPoint  :: EndPoint+	  , connHooks     :: Maybe (StreamHooks a)+	  , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.+          }+ | ConnClosed+   deriving(Eq)++hstreamToConnection :: HandleStream String -> Connection+hstreamToConnection h = Connection h++connHooks' :: Conn a -> Maybe (StreamHooks a)+connHooks' ConnClosed{} = Nothing+connHooks' x = connHooks x++-- all of these are post-op hooks+data StreamHooks ty+ = StreamHooks+     { hook_readLine   :: (ty -> String) -> Result ty -> IO ()+     , hook_readBlock  :: (ty -> String) -> Int -> Result ty -> IO ()+     , hook_writeBlock :: (ty -> String) -> ty  -> Result () -> IO ()+     , hook_close      :: IO ()+     , hook_name       :: String -- hack alert: name of the hook itself.+     }++instance Eq ty => Eq (StreamHooks ty) where+  (==) _ _ = True++nullHooks :: StreamHooks ty+nullHooks = StreamHooks +     { hook_readLine   = \ _ _   -> return ()+     , hook_readBlock  = \ _ _ _ -> return ()+     , hook_writeBlock = \ _ _ _ -> return ()+     , hook_close      = return ()+     , hook_name       = ""+     }++setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO ()+setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh})++getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty))+getStreamHooks h = readMVar (getRef h) >>= return.connHooks++-- | @HStream@ overloads the use of 'HandleStream's, letting you+-- overload the handle operations over the type that is communicated+-- across the handle. It comes in handy for @Network.HTTP@ 'Request'+-- and 'Response's as the payload representation isn't fixed, but overloaded.+--+-- The library comes with instances for @ByteString@s and @String@, but+-- should you want to plug in your own payload representation, defining+-- your own @HStream@ instance _should_ be all that it takes.+-- +class BufferType bufType => HStream bufType where+  openStream       :: String -> Int -> IO (HandleStream bufType)+  openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType)+  readLine         :: HandleStream bufType -> IO (Result bufType)+  readBlock        :: HandleStream bufType -> Int -> IO (Result bufType)+  writeBlock       :: HandleStream bufType -> bufType -> IO (Result ())+  close            :: HandleStream bufType -> IO ()+  closeQuick       :: HandleStream bufType -> IO ()+  closeOnEnd       :: HandleStream bufType -> Bool -> IO ()+  +instance HStream Strict.ByteString where+  openStream       = openTCPConnection+  openSocketStream = socketConnection+  readBlock c n    = readBlockBS c n+  readLine c       = readLineBS c+  writeBlock c str = writeBlockBS c str+  close c          = closeIt c Strict.null True+  closeQuick c     = closeIt c Strict.null False+  closeOnEnd c f   = closeEOF c f++instance HStream Lazy.ByteString where+    openStream       = \ a b -> openTCPConnection_ a b True+    openSocketStream = \ a b c -> socketConnection_ a b c True+    readBlock c n    = readBlockBS c n+    readLine c       = readLineBS c+    writeBlock c str = writeBlockBS c str+    close c          = closeIt c Lazy.null True+    closeQuick c     = closeIt c Lazy.null False+    closeOnEnd c f   = closeEOF c f++instance Stream.Stream Connection where+  readBlock (Connection c)     = Network.TCP.readBlock c+  readLine (Connection c)      = Network.TCP.readLine c+  writeBlock (Connection c)    = Network.TCP.writeBlock c +  close (Connection c)         = Network.TCP.close c+  closeOnEnd (Connection c) f  = Network.TCP.closeEOF c f+  +instance HStream String where+    openStream      = openTCPConnection+    openSocketStream = socketConnection+    readBlock ref n = readBlockBS ref n++    -- This function uses a buffer, at this time the buffer is just 1000 characters.+    -- (however many bytes this is is left to the user to decypher)+    readLine ref = readLineBS ref+    -- The 'Connection' object allows no outward buffering, +    -- since in general messages are serialised in their entirety.+    writeBlock ref str = writeBlockBS ref str -- (stringToBuf str)++    -- Closes a Connection.  Connection will no longer+    -- allow any of the other Stream functions.  Notice that a Connection may close+    -- at any time before a call to this function.  This function is idempotent.+    -- (I think the behaviour here is TCP specific)+    close c = closeIt c null True+    +    -- Closes a Connection without munching the rest of the stream.+    closeQuick c = closeIt c null False++    closeOnEnd c f = closeEOF c f+    +-- | @openTCPPort uri port@  establishes a connection to a remote+-- host, using 'getHostByName' which possibly queries the DNS system, hence +-- may trigger a network connection.+openTCPPort :: String -> Int -> IO Connection+openTCPPort uri port = openTCPConnection uri port >>= return.Connection++-- Add a "persistent" option?  Current persistent is default.+-- Use "Result" type for synchronous exception reporting?+openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty)+openTCPConnection uri port = openTCPConnection_ uri port False++openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty)+openTCPConnection_ uri port stashInput = withSocket $ \s -> do+    setSocketOption s KeepAlive 1+    hostA <- getHostAddr uri+    let a = SockAddrInet (toEnum port) hostA+    connect s a+    socketConnection_ uri port s stashInput+ where+  withSocket action = do+    s <- socket AF_INET Stream 6+    catchIO (action s) (\e -> sClose s >> ioError e)+  getHostAddr h = do+    catchIO (inet_addr uri)    -- handles ascii IP numbers+            (\ _ -> do+	        host <- getHostByName_safe uri+                case hostAddresses host of+                  []     -> fail ("openTCPConnection: no addresses in host entry for " ++ show h)+                  (ha:_) -> return ha)++  getHostByName_safe h = +    catchIO (getHostByName h)+            (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h))++-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'.+socketConnection :: BufferType ty+                 => String+                 -> Int+		 -> Socket+		 -> IO (HandleStream ty)+socketConnection hst port sock = socketConnection_ hst port sock False++-- Internal function used to control the on-demand streaming of input+-- for /lazy/ streams.+socketConnection_ :: BufferType ty+                  => String+                  -> Int+		  -> Socket+		  -> Bool+		  -> IO (HandleStream ty)+socketConnection_ hst port sock stashInput = do+    h <- socketToHandle sock ReadWriteMode+    mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }+    let conn = MkConn +         { connSock     = sock+	 , connHandle   = h+	 , connBuffer   = bufferOps+	 , connInput    = mb+	 , connEndPoint = EndPoint hst port+	 , connHooks    = Nothing+	 , connCloseEOF = False+	 }+    v <- newMVar conn+    return (HandleStream v)++closeConnection :: HStream a => HandleStream a -> IO Bool -> IO ()+closeConnection ref readL = do+    -- won't hold onto the lock for the duration+    -- we are draining it...ToDo: have Connection+    -- into a shutting-down state so that other+    -- threads will simply back off if/when attempting+    -- to also close it.+  c <- readMVar (getRef ref)+  closeConn c `catchIO` (\_ -> return ())+  modifyMVar_ (getRef ref) (\ _ -> return ConnClosed)+ where+   -- Be kind to peer & close gracefully.+  closeConn ConnClosed = return ()+  closeConn conn = do+    let sk = connSock conn+    hFlush (connHandle conn)+    shutdown sk ShutdownSend+    suck readL+    hClose (connHandle conn)+    shutdown sk ShutdownReceive+    sClose sk++  suck :: IO Bool -> IO ()+  suck rd = do+    f <- rd+    if f then return () else suck rd++-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> EndPoint -> IO Bool+isConnectedTo (Connection conn) endPoint = do+   v <- readMVar (getRef conn)+   case v of+     ConnClosed -> print "aa" >> return False+     _ +      | connEndPoint v == endPoint ->+          catch (getPeerName (connSock v) >> return True) (const $ return False)+      | otherwise -> return False++isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool+isTCPConnectedTo conn endPoint = do+   v <- readMVar (getRef conn)+   case v of+     ConnClosed -> return False+     _ +      | connEndPoint v == endPoint ->+          catch (getPeerName (connSock v) >> return True) (const $ return False)+      | otherwise -> return False++readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)+readBlockBS ref n = onNonClosedDo ref $ \ conn -> do+   x <- bufferGetBlock ref n+   maybe (return ())+         (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x)+	 (connHooks' conn)+   return x++-- This function uses a buffer, at this time the buffer is just 1000 characters.+-- (however many bytes this is is left for the user to decipher)+readLineBS :: HStream a => HandleStream a -> IO (Result a)+readLineBS ref = onNonClosedDo ref $ \ conn -> do+   x <- bufferReadLine ref+   maybe (return ())+         (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x)+	 (connHooks' conn)+   return x++-- The 'Connection' object allows no outward buffering, +-- since in general messages are serialised in their entirety.+writeBlockBS :: HandleStream a -> a -> IO (Result ())+writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do+  x    <- bufferPutBlock (connBuffer conn) (connHandle conn) b+  maybe (return ())+        (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x)+	(connHooks' conn)+  return x++closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()+closeIt c p b = do+   closeConnection c (if b+                      then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True}+                      else return True)+   conn <- readMVar (getRef c)+   maybe (return ())+         (hook_close)+	 (connHooks' conn)++closeEOF :: HandleStream ty -> Bool -> IO ()+closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg})++bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a)+bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do+   case connInput conn of+    Just c -> do+      let (a,b) = buf_splitAt (connBuffer conn) n c+      modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b})+      return (return a)+    _ -> do+      Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)+                    (\ e -> +		       if isEOFError e +			then do+			  when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+			  return (return (buf_empty (connBuffer conn)))+			else return (failMisc (show e)))++bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ())+bufferPutBlock ops h b = +  Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ()))+                (\ e -> return (failMisc (show e)))++bufferReadLine :: HStream a => HandleStream a -> IO (Result a)+bufferReadLine ref = onNonClosedDo ref $ \ conn -> do+  case connInput conn of+   Just c -> do+    let (a,b0)  = buf_span (connBuffer conn) (/='\n') c+    let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0+    modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1})+    return (return (buf_append (connBuffer conn) a newl))+   _ -> Prelude.catch +              (buf_hGetLine (connBuffer conn) (connHandle conn) >>= +	            return . return . appendNL (connBuffer conn))+              (\ e ->+                 if isEOFError e+                  then do+	  	    when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+		    return (return   (buf_empty (connBuffer conn)))+                  else return (failMisc (show e)))+ where+   -- yes, this s**ks.. _may_ have to be addressed if perf+   -- suggests worthiness.+  appendNL ops b = buf_snoc ops b nl+  +  nl :: Word8+  nl = fromIntegral (fromEnum '\n')++onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)+onNonClosedDo h act = do+  x <- readMVar (getRef h)+  case x of+    ConnClosed{} -> return (failWith ErrorClosed)+    _ -> act x+
+ Network/URI.hs view
@@ -0,0 +1,1289 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+--------------------------------------------------------------------------------+-- |+--  Module      :  Network.URI+--  Copyright   :  (c) 2004, Graham Klyne+--  License     :  BSD-style (see end of this file)+--+--  Maintainer  :  Graham Klyne <gk@ninebynine.org>+--  Stability   :  provisional+--  Portability :  portable+--+--  This module defines functions for handling URIs.  It presents substantially the+--  same interface as the older GHC Network.URI module, but is implemented using+--  Parsec rather than a Regex library that is not available with Hugs.  The internal+--  representation of URI has been changed so that URI strings are more+--  completely preserved when round-tripping to a URI value and back.+--+--  In addition, four methods are provided for parsing different+--  kinds of URI string (as noted in RFC3986):+--      'parseURI',+--      'parseURIReference',+--      'parseRelativeReference' and+--      'parseAbsoluteURI'.+--+--  Further, four methods are provided for classifying different+--  kinds of URI string (as noted in RFC3986):+--      'isURI',+--      'isURIReference',+--      'isRelativeReference' and+--      'isAbsoluteURI'.+--+--  The long-standing official reference for URI handling was RFC2396 [1],+--  as updated by RFC 2732 [2], but this was replaced by a new specification,+--  RFC3986 [3] in January 2005.  This latter specification has been used+--  as the primary reference for constructing the URI parser implemented+--  here, and it is intended that there is a direct relationship between+--  the syntax definition in that document and this parser implementation.+--+--  RFC 1808 [4] contains a number of test cases for relative URI handling.+--  Dan Connolly's Python module @uripath.py@ [5] also contains useful details+--  and test cases.+--+--  Some of the code has been copied from the previous GHC implementation,+--  but the parser is replaced with one that performs more complete+--  syntax checking of the URI itself, according to RFC3986 [3].+--+--  References+--+--  (1) <http://www.ietf.org/rfc/rfc2396.txt>+--+--  (2) <http://www.ietf.org/rfc/rfc2732.txt>+--+--  (3) <http://www.ietf.org/rfc/rfc3986.txt>+--+--  (4) <http://www.ietf.org/rfc/rfc1808.txt>+--+--  (5) <http://www.w3.org/2000/10/swap/uripath.py>+--+--------------------------------------------------------------------------------++module Network.URI+    (+    -- * The URI type+      URI(..)+    , URIAuth(..)+    , nullURI+      +    -- * Parsing+    , parseURI+    , parseURIReference+    , parseRelativeReference+    , parseAbsoluteURI+      +    -- * Test for strings containing various kinds of URI+    , isURI+    , isURIReference+    , isRelativeReference+    , isAbsoluteURI+    , isIPv6address+    , isIPv4address+      +    -- * Relative URIs+    , relativeTo+    , nonStrictRelativeTo+    , relativeFrom+      +    -- * Operations on URI strings+    -- | Support for putting strings into URI-friendly+    --   escaped format and getting them back again.+    --   This can't be done transparently in all cases, because certain+    --   characters have different meanings in different kinds of URI.+    --   The URI spec [3], section 2.4, indicates that all URI components+    --   should be escaped before they are assembled as a URI:+    --   \"Once produced, a URI is always in its percent-encoded form\"+    , uriToString+    , isReserved, isUnreserved+    , isAllowedInURI, isUnescapedInURI+    , escapeURIChar+    , escapeURIString+    , unEscapeString+      +    -- * URI Normalization functions+    , normalizeCase+    , normalizeEscape+    , normalizePathSegments+      +    -- * Deprecated functions+    , parseabsoluteURI+    , escapeString+    , reserved, unreserved+    , scheme, authority, path, query, fragment+    ) where++import Text.ParserCombinators.Parsec+    ( GenParser, ParseError+    , parse, (<|>), (<?>), try+    , option, many, many1, count, notFollowedBy+    , char, satisfy, oneOf, string, eof+    , unexpected+    )++import Control.Monad (MonadPlus(..))+import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt)+import Debug.Trace (trace)+import Numeric (showIntAtBase)++#ifdef __GLASGOW_HASKELL__+import Data.Typeable (Typeable)+# if MIN_VERSION_base(4,0,0)+import Data.Data (Data)+# else+import Data.Generics (Data)+# endif+#else+import Data.Typeable (Typeable(..), TyCon, mkTyCon, mkTyConApp)+#endif++------------------------------------------------------------+--  The URI datatype+------------------------------------------------------------++-- |Represents a general universal resource identifier using+--  its component parts.+--+--  For example, for the URI+--+--  >   foo://anonymous@www.haskell.org:42/ghc?query#frag+--+--  the components are:+--+data URI = URI+    { uriScheme     :: String           -- ^ @foo:@+    , uriAuthority  :: Maybe URIAuth    -- ^ @\/\/anonymous\@www.haskell.org:42@+    , uriPath       :: String           -- ^ @\/ghc@+    , uriQuery      :: String           -- ^ @?query@+    , uriFragment   :: String           -- ^ @#frag@+    } deriving (Eq+#ifdef __GLASGOW_HASKELL__+    , Typeable, Data+#endif+    )++#ifndef __GLASGOW_HASKELL__+uriTc :: TyCon+uriTc = mkTyCon "URI"++instance Typeable URI where+  typeOf _ = mkTyConApp uriTc []+#endif++-- |Type for authority value within a URI+data URIAuth = URIAuth+    { uriUserInfo   :: String           -- ^ @anonymous\@@+    , uriRegName    :: String           -- ^ @www.haskell.org@+    , uriPort       :: String           -- ^ @:42@+    } deriving (Eq+#ifdef __GLASGOW_HASKELL__+    , Typeable, Data+#endif+    )++#ifndef __GLASGOW_HASKELL__+uriAuthTc :: TyCon+uriAuthTc = mkTyCon "URIAuth"++instance Typeable URIAuth where+  typeOf _ = mkTyConApp uriAuthTc []+#endif++-- |Blank URI+nullURI :: URI+nullURI = URI+    { uriScheme     = ""+    , uriAuthority  = Nothing+    , uriPath       = ""+    , uriQuery      = ""+    , uriFragment   = ""+    }++--  URI as instance of Show.  Note that for security reasons, the default+--  behaviour is to suppress any userinfo field (see RFC3986, section 7.5).+--  This can be overridden by using uriToString directly with first+--  argument @id@ (noting that this returns a ShowS value rather than a string).+--+--  [[[Another design would be to embed the userinfo mapping function in+--  the URIAuth value, with the default value suppressing userinfo formatting,+--  but providing a function to return a new URI value with userinfo+--  data exposed by show.]]]+--+instance Show URI where+    showsPrec _ = uriToString defaultUserInfoMap++defaultUserInfoMap :: String -> String+defaultUserInfoMap uinf = user++newpass+    where+        (user,pass) = break (==':') uinf+        newpass     = if null pass || (pass == "@")+                                   || (pass == ":@")+                        then pass+                        else ":...@"++testDefaultUserInfoMap :: [Bool]+testDefaultUserInfoMap =+     [ defaultUserInfoMap ""                == ""+     , defaultUserInfoMap "@"               == "@"+     , defaultUserInfoMap "user@"           == "user@"+     , defaultUserInfoMap "user:@"          == "user:@"+     , defaultUserInfoMap "user:anonymous@" == "user:...@"+     , defaultUserInfoMap "user:pass@"      == "user:...@"+     , defaultUserInfoMap "user:pass"       == "user:...@"+     , defaultUserInfoMap "user:anonymous"  == "user:...@"+     ]++------------------------------------------------------------+--  Parse a URI+------------------------------------------------------------++-- |Turn a string containing a URI into a 'URI'.+--  Returns 'Nothing' if the string is not a valid URI;+--  (an absolute URI with optional fragment identifier).+--+--  NOTE: this is different from the previous network.URI,+--  whose @parseURI@ function works like 'parseURIReference'+--  in this module.+--+parseURI :: String -> Maybe URI+parseURI = parseURIAny uri++-- |Parse a URI reference to a 'URI' value.+--  Returns 'Nothing' if the string is not a valid URI reference.+--  (an absolute or relative URI with optional fragment identifier).+--+parseURIReference :: String -> Maybe URI+parseURIReference = parseURIAny uriReference++-- |Parse a relative URI to a 'URI' value.+--  Returns 'Nothing' if the string is not a valid relative URI.+--  (a relative URI with optional fragment identifier).+--+parseRelativeReference :: String -> Maybe URI+parseRelativeReference = parseURIAny relativeRef++-- |Parse an absolute URI to a 'URI' value.+--  Returns 'Nothing' if the string is not a valid absolute URI.+--  (an absolute URI without a fragment identifier).+--+parseAbsoluteURI :: String -> Maybe URI+parseAbsoluteURI = parseURIAny absoluteURI++-- |Test if string contains a valid URI+--  (an absolute URI with optional fragment identifier).+--+isURI :: String -> Bool+isURI = isValidParse uri++-- |Test if string contains a valid URI reference+--  (an absolute or relative URI with optional fragment identifier).+--+isURIReference :: String -> Bool+isURIReference = isValidParse uriReference++-- |Test if string contains a valid relative URI+--  (a relative URI with optional fragment identifier).+--+isRelativeReference :: String -> Bool+isRelativeReference = isValidParse relativeRef++-- |Test if string contains a valid absolute URI+--  (an absolute URI without a fragment identifier).+--+isAbsoluteURI :: String -> Bool+isAbsoluteURI = isValidParse absoluteURI++-- |Test if string contains a valid IPv6 address+--+isIPv6address :: String -> Bool+isIPv6address = isValidParse ipv6address++-- |Test if string contains a valid IPv4 address+--+isIPv4address :: String -> Bool+isIPv4address = isValidParse ipv4address++-- |Test function: parse and reconstruct a URI reference+--+testURIReference :: String -> String+testURIReference uristr = show (parseAll uriReference "" uristr)++--  Helper function for turning a string into a URI+--+parseURIAny :: URIParser URI -> String -> Maybe URI+parseURIAny parser uristr = case parseAll parser "" uristr of+        Left  _ -> Nothing+        Right u -> Just u++--  Helper function to test a string match to a parser+--+isValidParse :: URIParser a -> String -> Bool+isValidParse parser uristr = case parseAll parser "" uristr of+        -- Left  e -> error (show e)+        Left  _ -> False+        Right _ -> True++parseAll :: URIParser a -> String -> String -> Either ParseError a+parseAll parser filename uristr = parse newparser filename uristr+    where+        newparser =+            do  { res <- parser+                ; eof+                ; return res+                }++------------------------------------------------------------+--  URI parser body based on Parsec elements and combinators+------------------------------------------------------------++--  Parser parser type.+--  Currently+type URIParser a = GenParser Char () a++--  RFC3986, section 2.1+--+--  Parse and return a 'pct-encoded' sequence+--+escaped :: URIParser String+escaped =+    do  { char '%'+        ; h1 <- hexDigitChar+        ; h2 <- hexDigitChar+        ; return $ ['%',h1,h2]+        }++--  RFC3986, section 2.2+--+-- |Returns 'True' if the character is a \"reserved\" character in a+--  URI.  To include a literal instance of one of these characters in a+--  component of a URI, it must be escaped.+--+isReserved :: Char -> Bool+isReserved c = isGenDelims c || isSubDelims c++isGenDelims :: Char -> Bool+isGenDelims c = c `elem` ":/?#[]@"++isSubDelims :: Char -> Bool+isSubDelims c = c `elem` "!$&'()*+,;="++genDelims :: URIParser String+genDelims = do { c <- satisfy isGenDelims ; return [c] }++subDelims :: URIParser String+subDelims = do { c <- satisfy isSubDelims ; return [c] }++--  RFC3986, section 2.3+--+-- |Returns 'True' if the character is an \"unreserved\" character in+--  a URI.  These characters do not need to be escaped in a URI.  The+--  only characters allowed in a URI are either \"reserved\",+--  \"unreserved\", or an escape sequence (@%@ followed by two hex digits).+--+isUnreserved :: Char -> Bool+isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")++unreservedChar :: URIParser String+unreservedChar = do { c <- satisfy isUnreserved ; return [c] }++--  RFC3986, section 3+--+--   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]+--+--   hier-part   = "//" authority path-abempty+--               / path-abs+--               / path-rootless+--               / path-empty++uri :: URIParser URI+uri =+    do  { us <- try uscheme+        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )+        -- ; up <- upath+        ; (ua,up) <- hierPart+        ; uq <- option "" ( do { char '?' ; uquery    } )+        ; uf <- option "" ( do { char '#' ; ufragment } )+        ; return $ URI+            { uriScheme    = us+            , uriAuthority = ua+            , uriPath      = up+            , uriQuery     = uq+            , uriFragment  = uf+            }+        }++hierPart :: URIParser ((Maybe URIAuth),String)+hierPart =+        do  { try (string "//")+            ; ua <- uauthority+            ; up <- pathAbEmpty+            ; return (ua,up)+            }+    <|> do  { up <- pathAbs+            ; return (Nothing,up)+            }+    <|> do  { up <- pathRootLess+            ; return (Nothing,up)+            }+    <|> do  { return (Nothing,"")+            }++--  RFC3986, section 3.1++uscheme :: URIParser String+uscheme =+    do  { s <- oneThenMany alphaChar (satisfy isSchemeChar)+        ; char ':'+        ; return $ s++":"+        }++--  RFC3986, section 3.2++uauthority :: URIParser (Maybe URIAuth)+uauthority =+    do  { uu <- option "" (try userinfo)+        ; uh <- host+        ; up <- option "" port+        ; return $ Just $ URIAuth+            { uriUserInfo = uu+            , uriRegName  = uh+            , uriPort     = up+            }+        }++--  RFC3986, section 3.2.1++userinfo :: URIParser String+userinfo =+    do  { uu <- many (uchar ";:&=+$,")+        ; char '@'+        ; return (concat uu ++"@")+        }++--  RFC3986, section 3.2.2++host :: URIParser String+host = ipLiteral <|> try ipv4address <|> regName++ipLiteral :: URIParser String+ipLiteral =+    do  { char '['+        ; ua <- ( ipv6address <|> ipvFuture )+        ; char ']'+        ; return $ "[" ++ ua ++ "]"+        }+    <?> "IP address literal"++ipvFuture :: URIParser String+ipvFuture =+    do  { char 'v'+        ; h <- hexDigitChar+        ; char '.'+        ; a <- many1 (satisfy isIpvFutureChar)+        ; return $ 'c':h:'.':a+        }++isIpvFutureChar :: Char -> Bool+isIpvFutureChar c = isUnreserved c || isSubDelims c || (c==';')++ipv6address :: URIParser String+ipv6address =+        try ( do+                { a2 <- count 6 h4c+                ; a3 <- ls32+                ; return $ concat a2 ++ a3+                } )+    <|> try ( do+                { string "::"+                ; a2 <- count 5 h4c+                ; a3 <- ls32+                ; return $ "::" ++ concat a2 ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 0+                ; string "::"+                ; a2 <- count 4 h4c+                ; a3 <- ls32+                ; return $ a1 ++ "::" ++ concat a2 ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 1+                ; string "::"+                ; a2 <- count 3 h4c+                ; a3 <- ls32+                ; return $ a1 ++ "::" ++ concat a2 ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 2+                ; string "::"+                ; a2 <- count 2 h4c+                ; a3 <- ls32+                ; return $ a1 ++ "::" ++ concat a2 ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 3+                ; string "::"+                ; a2 <- h4c+                ; a3 <- ls32+                ; return $ a1 ++ "::" ++ a2 ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 4+                ; string "::"+                ; a3 <- ls32+                ; return $ a1 ++ "::" ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 5+                ; string "::"+                ; a3 <- h4+                ; return $ a1 ++ "::" ++ a3+                } )+    <|> try ( do+                { a1 <- opt_n_h4c_h4 6+                ; string "::"+                ; return $ a1 ++ "::"+                } )+    <?> "IPv6 address"++opt_n_h4c_h4 :: Int -> URIParser String+opt_n_h4c_h4 n = option "" $+    do  { a1 <- countMinMax 0 n h4c+        ; a2 <- h4+        ; return $ concat a1 ++ a2+        }++ls32 :: URIParser String+ls32 =  try ( do+                { a1 <- h4c+                ; a2 <- h4+                ; return (a1++a2)+                } )+    <|> ipv4address++h4c :: URIParser String+h4c = try $+    do  { a1 <- h4+        ; char ':'+        ; notFollowedBy (char ':')+        ; return $ a1 ++ ":"+        }++h4 :: URIParser String+h4 = countMinMax 1 4 hexDigitChar++ipv4address :: URIParser String+ipv4address =+    do  { a1 <- decOctet ; char '.'+        ; a2 <- decOctet ; char '.'+        ; a3 <- decOctet ; char '.'+        ; a4 <- decOctet+        ; return $ a1++"."++a2++"."++a3++"."++a4+        }++decOctet :: URIParser String+decOctet =+    do  { a1 <- countMinMax 1 3 digitChar+        ; if (read a1 :: Integer) > 255 then+            fail "Decimal octet value too large"+          else+            return a1+        }++regName :: URIParser String+regName =+    do  { ss <- countMinMax 0 255 ( unreservedChar <|> escaped <|> subDelims )+        ; return $ concat ss+        }+    <?> "Registered name"++--  RFC3986, section 3.2.3++port :: URIParser String+port =+    do  { char ':'+        ; p <- many digitChar+        ; return (':':p)+        }++--+--  RFC3986, section 3.3+--+--   path          = path-abempty    ; begins with "/" or is empty+--                 / path-abs        ; begins with "/" but not "//"+--                 / path-noscheme   ; begins with a non-colon segment+--                 / path-rootless   ; begins with a segment+--                 / path-empty      ; zero characters+--+--   path-abempty  = *( "/" segment )+--   path-abs      = "/" [ segment-nz *( "/" segment ) ]+--   path-noscheme = segment-nzc *( "/" segment )+--   path-rootless = segment-nz *( "/" segment )+--   path-empty    = 0<pchar>+--+--   segment       = *pchar+--   segment-nz    = 1*pchar+--   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )+--+--   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"++{-+upath :: URIParser String+upath = pathAbEmpty+    <|> pathAbs+    <|> pathNoScheme+    <|> pathRootLess+    <|> pathEmpty+-}++pathAbEmpty :: URIParser String+pathAbEmpty =+    do  { ss <- many slashSegment+        ; return $ concat ss+        }++pathAbs :: URIParser String+pathAbs =+    do  { char '/'+        ; ss <- option "" pathRootLess+        ; return $ '/':ss+        }++pathNoScheme :: URIParser String+pathNoScheme =+    do  { s1 <- segmentNzc+        ; ss <- many slashSegment+        ; return $ concat (s1:ss)+        }++pathRootLess :: URIParser String+pathRootLess =+    do  { s1 <- segmentNz+        ; ss <- many slashSegment+        ; return $ concat (s1:ss)+        }++slashSegment :: URIParser String+slashSegment =+    do  { char '/'+        ; s <- segment+        ; return ('/':s)+        }++segment :: URIParser String+segment =+    do  { ps <- many pchar+        ; return $ concat ps+        }++segmentNz :: URIParser String+segmentNz =+    do  { ps <- many1 pchar+        ; return $ concat ps+        }++segmentNzc :: URIParser String+segmentNzc =+    do  { ps <- many1 (uchar "@")+        ; return $ concat ps+        }++pchar :: URIParser String+pchar = uchar ":@"++-- helper function for pchar and friends+uchar :: String -> URIParser String+uchar extras =+        unreservedChar+    <|> escaped+    <|> subDelims+    <|> do { c <- oneOf extras ; return [c] }++--  RFC3986, section 3.4++uquery :: URIParser String+uquery =+    do  { ss <- many $ uchar (":@"++"/?")+        ; return $ '?':concat ss+        }++--  RFC3986, section 3.5++ufragment :: URIParser String+ufragment =+    do  { ss <- many $ uchar (":@"++"/?")+        ; return $ '#':concat ss+        }++--  Reference, Relative and Absolute URI forms+--+--  RFC3986, section 4.1++uriReference :: URIParser URI+uriReference = uri <|> relativeRef++--  RFC3986, section 4.2+--+--   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]+--+--   relative-part = "//" authority path-abempty+--                 / path-abs+--                 / path-noscheme+--                 / path-empty++relativeRef :: URIParser URI+relativeRef =+    do  { notMatching uscheme+        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )+        -- ; up <- upath+        ; (ua,up) <- relativePart+        ; uq <- option "" ( do { char '?' ; uquery    } )+        ; uf <- option "" ( do { char '#' ; ufragment } )+        ; return $ URI+            { uriScheme    = ""+            , uriAuthority = ua+            , uriPath      = up+            , uriQuery     = uq+            , uriFragment  = uf+            }+        }++relativePart :: URIParser ((Maybe URIAuth),String)+relativePart =+        do  { try (string "//")+            ; ua <- uauthority+            ; up <- pathAbEmpty+            ; return (ua,up)+            }+    <|> do  { up <- pathAbs+            ; return (Nothing,up)+            }+    <|> do  { up <- pathNoScheme+            ; return (Nothing,up)+            }+    <|> do  { return (Nothing,"")+            }++--  RFC3986, section 4.3++absoluteURI :: URIParser URI+absoluteURI =+    do  { us <- uscheme+        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )+        -- ; up <- upath+        ; (ua,up) <- hierPart+        ; uq <- option "" ( do { char '?' ; uquery    } )+        ; return $ URI+            { uriScheme    = us+            , uriAuthority = ua+            , uriPath      = up+            , uriQuery     = uq+            , uriFragment  = ""+            }+        }++--  Imports from RFC 2234++    -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859+    -- (and possibly Unicode!) chars.+    -- [[[Above was a comment originally in GHC Network/URI.hs:+    --    when IRIs are introduced then most codepoints above 128(?) should+    --    be treated as unreserved, and higher codepoints for letters should+    --    certainly be allowed.+    -- ]]]++isAlphaChar :: Char -> Bool+isAlphaChar c    = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')++isDigitChar :: Char -> Bool+isDigitChar c    = (c >= '0' && c <= '9')++isAlphaNumChar :: Char -> Bool+isAlphaNumChar c = isAlphaChar c || isDigitChar c++isHexDigitChar :: Char -> Bool+isHexDigitChar c = isHexDigit c++isSchemeChar :: Char -> Bool+isSchemeChar c   = (isAlphaNumChar c) || (c `elem` "+-.")++alphaChar :: URIParser Char+alphaChar = satisfy isAlphaChar         -- or: Parsec.letter ?++digitChar :: URIParser Char+digitChar = satisfy isDigitChar         -- or: Parsec.digit ?++alphaNumChar :: URIParser Char+alphaNumChar = satisfy isAlphaNumChar++hexDigitChar :: URIParser Char+hexDigitChar = satisfy isHexDigitChar   -- or: Parsec.hexDigit ?++--  Additional parser combinators for common patterns++oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a]+oneThenMany p1 pr =+    do  { a1 <- p1+        ; ar <- many pr+        ; return (a1:ar)+        }++countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a]+countMinMax m n p | m > 0 =+    do  { a1 <- p+        ; ar <- countMinMax (m-1) (n-1) p+        ; return (a1:ar)+        }+countMinMax _ n _ | n <= 0 = return []+countMinMax _ n p = option [] $+    do  { a1 <- p+        ; ar <- countMinMax 0 (n-1) p+        ; return (a1:ar)+        }++notMatching :: Show a => GenParser tok st a -> GenParser tok st ()+notMatching p = do { a <- try p ; unexpected (show a) } <|> return ()++------------------------------------------------------------+--  Reconstruct a URI string+------------------------------------------------------------+--+-- |Turn a 'URI' into a string.+--+--  Uses a supplied function to map the userinfo part of the URI.+--+--  The Show instance for URI uses a mapping that hides any password+--  that may be present in the URI.  Use this function with argument @id@+--  to preserve the password in the formatted output.+--+uriToString :: (String->String) -> URI -> ShowS+uriToString userinfomap URI { uriScheme=myscheme+                            , uriAuthority=myauthority+                            , uriPath=mypath+                            , uriQuery=myquery+                            , uriFragment=myfragment+                            } =+    (myscheme++) . (uriAuthToString userinfomap myauthority)+               . (mypath++) . (myquery++) . (myfragment++)++uriAuthToString :: (String->String) -> (Maybe URIAuth) -> ShowS+uriAuthToString _           Nothing   = id          -- shows ""+uriAuthToString userinfomap+        (Just URIAuth { uriUserInfo = myuinfo+                      , uriRegName  = myregname+                      , uriPort     = myport+                      } ) =+    ("//"++) . (if null myuinfo then id else ((userinfomap myuinfo)++))+             . (myregname++)+             . (myport++)++------------------------------------------------------------+--  Character classes+------------------------------------------------------------++-- | Returns 'True' if the character is allowed in a URI.+--+isAllowedInURI :: Char -> Bool+isAllowedInURI c = isReserved c || isUnreserved c || c == '%' -- escape char++-- | Returns 'True' if the character is allowed unescaped in a URI.+--+isUnescapedInURI :: Char -> Bool+isUnescapedInURI c = isReserved c || isUnreserved c++------------------------------------------------------------+--  Escape sequence handling+------------------------------------------------------------++-- |Escape character if supplied predicate is not satisfied,+--  otherwise return character as singleton string.+--+escapeURIChar :: (Char->Bool) -> Char -> String+escapeURIChar p c+    | p c       = [c]+    | otherwise = '%' : myShowHex (ord c) ""+    where+        myShowHex :: Int -> ShowS+        myShowHex n r =  case showIntAtBase 16 (toChrHex) n r of+            []  -> "00"+            [x] -> ['0',x]+            cs  -> cs+        toChrHex d+            | d < 10    = chr (ord '0' + fromIntegral d)+            | otherwise = chr (ord 'A' + fromIntegral (d - 10))++-- |Can be used to make a string valid for use in a URI.+--+escapeURIString+    :: (Char->Bool)     -- ^ a predicate which returns 'False'+                        --   if the character should be escaped+    -> String           -- ^ the string to process+    -> String           -- ^ the resulting URI string+escapeURIString p s = concatMap (escapeURIChar p) s++-- |Turns all instances of escaped characters in the string back+--  into literal characters.+--+unEscapeString :: String -> String+unEscapeString [] = ""+unEscapeString ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =+    chr (digitToInt x1 * 16 + digitToInt x2) : unEscapeString s+unEscapeString (c:s) = c : unEscapeString s++------------------------------------------------------------+-- Resolving a relative URI relative to a base URI+------------------------------------------------------------++-- |Returns a new 'URI' which represents the value of the+--  first 'URI' interpreted as relative to the second 'URI'.+--  For example:+--+--  > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo"+--  > "http:foo" `nonStrictRelativeTo` "http://bar.org/" = "http://bar.org/foo"+--+--  Algorithm from RFC3986 [3], section 5.2.2+--++nonStrictRelativeTo :: URI -> URI -> Maybe URI+nonStrictRelativeTo ref base = relativeTo ref' base+    where+        ref' = if uriScheme ref == uriScheme base+               then ref { uriScheme="" }+               else ref++isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool+isDefined a = a /= mzero++-- |Compute an absolute 'URI' for a supplied URI+--  relative to a given base.+relativeTo :: URI -> URI -> Maybe URI+relativeTo ref base+    | isDefined ( uriScheme ref ) =+        just_segments ref+    | isDefined ( uriAuthority ref ) =+        just_segments ref { uriScheme = uriScheme base }+    | isDefined ( uriPath ref ) =+        if (head (uriPath ref) == '/') then+            just_segments ref+                { uriScheme    = uriScheme base+                , uriAuthority = uriAuthority base+                }+        else+            just_segments ref+                { uriScheme    = uriScheme base+                , uriAuthority = uriAuthority base+                , uriPath      = mergePaths base ref+                }+    | isDefined ( uriQuery ref ) =+        just_segments ref+            { uriScheme    = uriScheme base+            , uriAuthority = uriAuthority base+            , uriPath      = uriPath base+            }+    | otherwise =+        just_segments ref+            { uriScheme    = uriScheme base+            , uriAuthority = uriAuthority base+            , uriPath      = uriPath base+            , uriQuery     = uriQuery base+            }+    where+        just_segments u =+            Just $ u { uriPath = removeDotSegments (uriPath u) }+        mergePaths b r+            | isDefined (uriAuthority b) && null pb = '/':pr+            | otherwise                             = dropLast pb ++ pr+            where+                pb = uriPath b+                pr = uriPath r+        dropLast = fst . splitLast -- reverse . dropWhile (/='/') . reverse++--  Remove dot segments, but protect leading '/' character+removeDotSegments :: String -> String+removeDotSegments ('/':ps) = '/':elimDots ps []+removeDotSegments ps       = elimDots ps []++--  Second arg accumulates segments processed so far in reverse order+elimDots :: String -> [String] -> String+-- elimDots ps rs | traceVal "\nps " ps $ traceVal "rs " rs $ False = error ""+elimDots [] [] = ""+elimDots [] rs = concat (reverse rs)+elimDots (    '.':'/':ps)     rs = elimDots ps rs+elimDots (    '.':[]    )     rs = elimDots [] rs+elimDots (    '.':'.':'/':ps) rs = elimDots ps (drop 1 rs)+elimDots (    '.':'.':[]    ) rs = elimDots [] (drop 1 rs)+elimDots ps rs = elimDots ps1 (r:rs)+    where+        (r,ps1) = nextSegment ps++--  Returns the next segment and the rest of the path from a path string.+--  Each segment ends with the next '/' or the end of string.+--+nextSegment :: String -> (String,String)+nextSegment ps =+    case break (=='/') ps of+        (r,'/':ps1) -> (r++"/",ps1)+        (r,_)       -> (r,[])++--  Split last (name) segment from path, returning (path,name)+splitLast :: String -> (String,String)+splitLast p = (reverse revpath,reverse revname)+    where+        (revname,revpath) = break (=='/') $ reverse p++------------------------------------------------------------+-- Finding a URI relative to a base URI+------------------------------------------------------------++-- |Returns a new 'URI' which represents the relative location of+--  the first 'URI' with respect to the second 'URI'.  Thus, the+--  values supplied are expected to be absolute URIs, and the result+--  returned may be a relative URI.+--+--  Example:+--+--  > "http://example.com/Root/sub1/name2#frag"+--  >   `relativeFrom` "http://example.com/Root/sub2/name2#frag"+--  >   == "../sub1/name2#frag"+--+--  There is no single correct implementation of this function,+--  but any acceptable implementation must satisfy the following:+--+--  > (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs+--+--  For any valid absolute URI.+--  (cf. <http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html>+--       <http://lists.w3.org/Archives/Public/uri/2003Jan/0005.html>)+--+relativeFrom :: URI -> URI -> URI+relativeFrom uabs base+    | diff uriScheme    uabs base = uabs+    | diff uriAuthority uabs base = uabs { uriScheme = "" }+    | diff uriPath      uabs base = uabs+        { uriScheme    = ""+        , uriAuthority = Nothing+        , uriPath      = relPathFrom (removeBodyDotSegments $ uriPath uabs)+                                     (removeBodyDotSegments $ uriPath base)+        }+    | diff uriQuery     uabs base = uabs+        { uriScheme    = ""+        , uriAuthority = Nothing+        , uriPath      = ""+        }+    | otherwise = uabs          -- Always carry fragment from uabs+        { uriScheme    = ""+        , uriAuthority = Nothing+        , uriPath      = ""+        , uriQuery     = ""+        }+    where+        diff :: Eq b => (a -> b) -> a -> a -> Bool+        diff sel u1 u2 = sel u1 /= sel u2+        -- Remove dot segments except the final segment+        removeBodyDotSegments p = removeDotSegments p1 ++ p2+            where+                (p1,p2) = splitLast p++relPathFrom :: String -> String -> String+relPathFrom []   _    = "/"+relPathFrom pabs []   = pabs+relPathFrom pabs base =                 -- Construct a relative path segments+    if sa1 == sb1                       -- if the paths share a leading segment+        then if (sa1 == "/")            -- other than a leading '/'+            then if (sa2 == sb2)+                then relPathFrom1 ra2 rb2+                else pabs+            else relPathFrom1 ra1 rb1+        else pabs+    where+        (sa1,ra1) = nextSegment pabs+        (sb1,rb1) = nextSegment base+        (sa2,ra2) = nextSegment ra1+        (sb2,rb2) = nextSegment rb1++--  relPathFrom1 strips off trailing names from the supplied paths,+--  and calls difPathFrom to find the relative path from base to+--  target+relPathFrom1 :: String -> String -> String+relPathFrom1 pabs base = relName+    where+        (sa,na) = splitLast pabs+        (sb,nb) = splitLast base+        rp      = relSegsFrom sa sb+        relName = if null rp then+                      if (na == nb) then ""+                      else if protect na then "./"++na+                      else na+                  else+                      rp++na+        -- Precede name with some path if it is null or contains a ':'+        protect s = null s || ':' `elem` s++--  relSegsFrom discards any common leading segments from both paths,+--  then invokes difSegsFrom to calculate a relative path from the end+--  of the base path to the end of the target path.+--  The final name is handled separately, so this deals only with+--  "directory" segtments.+--+relSegsFrom :: String -> String -> String+{-+relSegsFrom sabs base+    | traceVal "\nrelSegsFrom\nsabs " sabs $ traceVal "base " base $+      False = error ""+-}+relSegsFrom []   []   = ""      -- paths are identical+relSegsFrom sabs base =+    if sa1 == sb1+        then relSegsFrom ra1 rb1+        else difSegsFrom sabs base+    where+        (sa1,ra1) = nextSegment sabs+        (sb1,rb1) = nextSegment base++--  difSegsFrom calculates a path difference from base to target,+--  not including the final name at the end of the path+--  (i.e. results always ends with '/')+--+--  This function operates under the invariant that the supplied+--  value of sabs is the desired path relative to the beginning of+--  base.  Thus, when base is empty, the desired path has been found.+--+difSegsFrom :: String -> String -> String+{-+difSegsFrom sabs base+    | traceVal "\ndifSegsFrom\nsabs " sabs $ traceVal "base " base $+      False = error ""+-}+difSegsFrom sabs ""   = sabs+difSegsFrom sabs base = difSegsFrom ("../"++sabs) (snd $ nextSegment base)++------------------------------------------------------------+--  Other normalization functions+------------------------------------------------------------++-- |Case normalization; cf. RFC3986 section 6.2.2.1+--  NOTE:  authority case normalization is not performed+--+normalizeCase :: String -> String+normalizeCase uristr = ncScheme uristr+    where+        ncScheme (':':cs)                = ':':ncEscape cs+        ncScheme (c:cs) | isSchemeChar c = toLower c:ncScheme cs+        ncScheme _                       = ncEscape uristr -- no scheme present+        ncEscape ('%':h1:h2:cs) = '%':toUpper h1:toUpper h2:ncEscape cs+        ncEscape (c:cs)         = c:ncEscape cs+        ncEscape []             = []++-- |Encoding normalization; cf. RFC3986 section 6.2.2.2+--+normalizeEscape :: String -> String+normalizeEscape ('%':h1:h2:cs)+    | isHexDigit h1 && isHexDigit h2 && isUnreserved escval =+        escval:normalizeEscape cs+    where+        escval = chr (digitToInt h1*16+digitToInt h2)+normalizeEscape (c:cs)         = c:normalizeEscape cs+normalizeEscape []             = []++-- |Path segment normalization; cf. RFC3986 section 6.2.2.4+--+normalizePathSegments :: String -> String+normalizePathSegments uristr = normstr juri+    where+        juri = parseURI uristr+        normstr Nothing  = uristr+        normstr (Just u) = show (normuri u)+        normuri u = u { uriPath = removeDotSegments (uriPath u) }++------------------------------------------------------------+--  Local trace helper functions+------------------------------------------------------------++traceShow :: Show a => String -> a -> a+traceShow msg x = trace (msg ++ show x) x++traceVal :: Show a => String -> a -> b -> b+traceVal msg x y = trace (msg ++ show x) y++------------------------------------------------------------+--  Deprecated functions+------------------------------------------------------------++{-# DEPRECATED parseabsoluteURI "use parseAbsoluteURI" #-}+parseabsoluteURI :: String -> Maybe URI+parseabsoluteURI = parseAbsoluteURI++{-# DEPRECATED escapeString "use escapeURIString, and note the flipped arguments" #-}+escapeString :: String -> (Char->Bool) -> String+escapeString = flip escapeURIString++{-# DEPRECATED reserved "use isReserved" #-}+reserved :: Char -> Bool+reserved = isReserved++{-# DEPRECATED unreserved "use isUnreserved" #-}+unreserved :: Char -> Bool+unreserved = isUnreserved++--  Additional component access functions for backward compatibility++{-# DEPRECATED scheme "use uriScheme" #-}+scheme :: URI -> String+scheme = orNull init . uriScheme++{-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-}+authority :: URI -> String+authority = dropss . ($"") . uriAuthToString id . uriAuthority+    where+        -- Old-style authority component does not include leading '//'+        dropss ('/':'/':s) = s+        dropss s           = s++{-# DEPRECATED path "use uriPath" #-}+path :: URI -> String+path = uriPath++{-# DEPRECATED query "use uriQuery, and note changed functionality" #-}+query :: URI -> String+query = orNull tail . uriQuery++{-# DEPRECATED fragment "use uriFragment, and note changed functionality" #-}+fragment :: URI -> String+fragment = orNull tail . uriFragment++orNull :: ([a]->[a]) -> [a] -> [a]+orNull _ [] = []+orNull f as = f as++--------------------------------------------------------------------------------+--+--  Copyright (c) 2004, G. KLYNE.  All rights reserved.+--  Distributed as free software under the following license.+--+--  Redistribution and use in source and binary forms, with or without+--  modification, are permitted provided that the following conditions+--  are met:+--+--  - Redistributions of source code must retain the above copyright notice,+--  this list of conditions and the following disclaimer.+--+--  - Redistributions in binary form must reproduce the above copyright+--  notice, this list of conditions and the following disclaimer in the+--  documentation and/or other materials provided with the distribution.+--+--  - Neither name of the copyright holders nor the names of its+--  contributors may be used to endorse or promote products derived from+--  this software without specific prior written permission.+--+--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+--  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+--  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+--  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+--  HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+--  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+--  BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+--  OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+--  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+--  TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+--  USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+--------------------------------------------------------------------------------
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMainWithHooks autoconfUserHooks
+ System/Random.hs view
@@ -0,0 +1,567 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Random+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE in the 'random' repository)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This library deals with the common task of pseudo-random number+-- generation. The library makes it possible to generate repeatable+-- results, by starting with a specified initial random number generator,+-- or to get different results on each run by using the system-initialised+-- generator or by supplying a seed from some other source.+--+-- The library is split into two layers: +--+-- * A core /random number generator/ provides a supply of bits.+--   The class 'RandomGen' provides a common interface to such generators.+--   The library provides one instance of 'RandomGen', the abstract+--   data type 'StdGen'.  Programmers may, of course, supply their own+--   instances of 'RandomGen'.+--+-- * The class 'Random' provides a way to extract values of a particular+--   type from a random number generator.  For example, the 'Float'+--   instance of 'Random' allows one to generate random values of type+--   'Float'.+--+-- This implementation uses the Portable Combined Generator of L'Ecuyer+-- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by+-- Lennart Augustsson.  It has a period of roughly 2.30584e18.+--+-----------------------------------------------------------------------------++#include "MachDeps.h"++module System.Random+	(++	-- $intro++	-- * Random number generators++#ifdef ENABLE_SPLITTABLEGEN+	  RandomGen(next, genRange)+	, SplittableGen(split)+#else+	  RandomGen(next, genRange, split)+#endif+	-- ** Standard random number generators+	, StdGen+	, mkStdGen++	-- ** The global random number generator++	-- $globalrng++	, getStdRandom+	, getStdGen+	, setStdGen+	, newStdGen++	-- * Random values of various types+	, Random ( random,   randomR,+		   randoms,  randomRs,+		   randomIO, randomRIO )++	-- * References+	-- $references++	) where++import Prelude++import Data.Bits+import Data.Int+import Data.Word+import Foreign.C.Types++#ifdef __NHC__+import CPUTime		( getCPUTime )+import Foreign.Ptr      ( Ptr, nullPtr )+import Foreign.C	( CTime, CUInt )+#else+import System.CPUTime	( getCPUTime )+import Data.Time	( getCurrentTime, UTCTime(..) )+import Data.Ratio       ( numerator, denominator )+#endif+import Data.Char	( isSpace, chr, ord )+import System.IO.Unsafe ( unsafePerformIO )+import Data.IORef+import Numeric		( readDec )++-- The standard nhc98 implementation of Time.ClockTime does not match+-- the extended one expected in this module, so we lash-up a quick+-- replacement here.+#ifdef __NHC__+foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime+getTime :: IO (Integer, Integer)+getTime = do CTime t <- readtime nullPtr;  return (toInteger t, 0)+#else+getTime :: IO (Integer, Integer)+getTime = do+  utc <- getCurrentTime+  let daytime = toRational $ utctDayTime utc+  return $ quotRem (numerator daytime) (denominator daytime)+#endif++-- | The class 'RandomGen' provides a common interface to random number+-- generators.+--+#ifdef ENABLE_SPLITTABLEGEN+-- Minimal complete definition: 'next'.+#else+-- Minimal complete definition: 'next' and 'split'.+#endif++class RandomGen g where++   -- |The 'next' operation returns an 'Int' that is uniformly distributed+   -- in the range returned by 'genRange' (including both end points),+   -- and a new generator.+   next     :: g -> (Int, g)++   -- |The 'genRange' operation yields the range of values returned by+   -- the generator.+   --+   -- It is required that:+   --+   -- * If @(a,b) = 'genRange' g@, then @a < b@.+   --+   -- * 'genRange' always returns a pair of defined 'Int's.+   --+   -- The second condition ensures that 'genRange' cannot examine its+   -- argument, and hence the value it returns can be determined only by the+   -- instance of 'RandomGen'.  That in turn allows an implementation to make+   -- a single call to 'genRange' to establish a generator's range, without+   -- being concerned that the generator returned by (say) 'next' might have+   -- a different range to the generator passed to 'next'.+   --+   -- The default definition spans the full range of 'Int'.+   genRange :: g -> (Int,Int)++   -- default method+   genRange _ = (minBound, maxBound)++#ifdef ENABLE_SPLITTABLEGEN+-- | The class 'SplittableGen' proivides a way to specify a random number+--   generator that can be split into two new generators.+class SplittableGen g where+#endif+   -- |The 'split' operation allows one to obtain two distinct random number+   -- generators. This is very useful in functional programs (for example, when+   -- passing a random number generator down to recursive calls), but very+   -- little work has been done on statistically robust implementations of+   -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"]+   -- are the only examples we know of).+   split    :: g -> (g, g)++{- |+The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits.++The result of repeatedly using 'next' should be at least as statistically+robust as the /Minimal Standard Random Number Generator/ described by+["System.Random\#Park", "System.Random\#Carta"].+Until more is known about implementations of 'split', all we require is+that 'split' deliver generators that are (a) not identical and+(b) independently robust in the sense just given.++The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the+state of a random number generator.+It is required that @'read' ('show' g) == g@.++In addition, 'reads' may be used to map an arbitrary string (not necessarily one+produced by 'show') onto a value of type 'StdGen'. In general, the 'Read'+instance of 'StdGen' has the following properties: ++* It guarantees to succeed on any string. ++* It guarantees to consume only a finite portion of the string. ++* Different argument strings are likely to result in different results.++-}++data StdGen + = StdGen Int32 Int32++instance RandomGen StdGen where+  next  = stdNext+  genRange _ = stdRange++#ifdef ENABLE_SPLITTABLEGEN+instance SplittableGen StdGen where+#endif+  split = stdSplit++instance Show StdGen where+  showsPrec p (StdGen s1 s2) = +     showsPrec p s1 . +     showChar ' ' .+     showsPrec p s2++instance Read StdGen where+  readsPrec _p = \ r ->+     case try_read r of+       r'@[_] -> r'+       _   -> [stdFromString r] -- because it shouldn't ever fail.+    where +      try_read r = do+         (s1, r1) <- readDec (dropWhile isSpace r)+	 (s2, r2) <- readDec (dropWhile isSpace r1)+	 return (StdGen s1 s2, r2)++{-+ If we cannot unravel the StdGen from a string, create+ one based on the string given.+-}+stdFromString         :: String -> (StdGen, String)+stdFromString s        = (mkStdGen num, rest)+	where (cs, rest) = splitAt 6 s+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)+++{- |+The function 'mkStdGen' provides an alternative way of producing an initial+generator, by mapping an 'Int' into a generator. Again, distinct arguments+should be likely to produce distinct generators.+-}+mkStdGen :: Int -> StdGen -- why not Integer ?+mkStdGen s = mkStdGen32 $ fromIntegral s++mkStdGen32 :: Int32 -> StdGen+mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1)+      where+	-- We want a non-negative number, but we can't just take the abs+	-- of sMaybeNegative as -minBound == minBound.+	s       = sMaybeNegative .&. maxBound+	(q, s1) = s `divMod` 2147483562+	s2      = q `mod` 2147483398++createStdGen :: Integer -> StdGen+createStdGen s = mkStdGen32 $ fromIntegral s++-- FIXME: 1/2/3 below should be ** (vs@30082002) XXX++{- |+With a source of random number supply in hand, the 'Random' class allows the+programmer to extract random values of a variety of types.++Minimal complete definition: 'randomR' and 'random'.++-}++class Random a where+  -- | Takes a range /(lo,hi)/ and a random number generator+  -- /g/, and returns a random value uniformly distributed in the closed+  -- interval /[lo,hi]/, together with a new generator. It is unspecified+  -- what happens if /lo>hi/. For continuous types there is no requirement+  -- that the values /lo/ and /hi/ are ever produced, but they may be,+  -- depending on the implementation and the interval.+  randomR :: RandomGen g => (a,a) -> g -> (a,g)++  -- | The same as 'randomR', but using a default range determined by the type:+  --+  -- * For bounded types (instances of 'Bounded', such as 'Char'),+  --   the range is normally the whole type.+  --+  -- * For fractional types, the range is normally the semi-closed interval+  -- @[0,1)@.+  --+  -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.+  random  :: RandomGen g => g -> (a, g)++  -- | Plural variant of 'randomR', producing an infinite list of+  -- random values instead of returning a new generator.+  randomRs :: RandomGen g => (a,a) -> g -> [a]+  randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g++  -- | Plural variant of 'random', producing an infinite list of+  -- random values instead of returning a new generator.+  randoms  :: RandomGen g => g -> [a]+  randoms  g      = (\(x,g') -> x : randoms g') (random g)++  -- | A variant of 'randomR' that uses the global random number generator+  -- (see "System.Random#globalrng").+  randomRIO :: (a,a) -> IO a+  randomRIO range  = getStdRandom (randomR range)++  -- | A variant of 'random' that uses the global random number generator+  -- (see "System.Random#globalrng").+  randomIO  :: IO a+  randomIO	   = getStdRandom random+++instance Random Integer where+  randomR ival g = randomIvalInteger ival g+  random g	 = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g++instance Random Int        where randomR = randomIvalIntegral; random = randomBounded+instance Random Int8       where randomR = randomIvalIntegral; random = randomBounded+instance Random Int16      where randomR = randomIvalIntegral; random = randomBounded+instance Random Int32      where randomR = randomIvalIntegral; random = randomBounded+instance Random Int64      where randomR = randomIvalIntegral; random = randomBounded++#ifndef __NHC__+-- Word is a type synonym in nhc98.+instance Random Word       where randomR = randomIvalIntegral; random = randomBounded+#endif+instance Random Word8      where randomR = randomIvalIntegral; random = randomBounded+instance Random Word16     where randomR = randomIvalIntegral; random = randomBounded+instance Random Word32     where randomR = randomIvalIntegral; random = randomBounded+instance Random Word64     where randomR = randomIvalIntegral; random = randomBounded++instance Random CChar      where randomR = randomIvalIntegral; random = randomBounded+instance Random CSChar     where randomR = randomIvalIntegral; random = randomBounded+instance Random CUChar     where randomR = randomIvalIntegral; random = randomBounded+instance Random CShort     where randomR = randomIvalIntegral; random = randomBounded+instance Random CUShort    where randomR = randomIvalIntegral; random = randomBounded+instance Random CInt       where randomR = randomIvalIntegral; random = randomBounded+instance Random CUInt      where randomR = randomIvalIntegral; random = randomBounded+instance Random CLong      where randomR = randomIvalIntegral; random = randomBounded+instance Random CULong     where randomR = randomIvalIntegral; random = randomBounded+instance Random CPtrdiff   where randomR = randomIvalIntegral; random = randomBounded+instance Random CSize      where randomR = randomIvalIntegral; random = randomBounded+instance Random CWchar     where randomR = randomIvalIntegral; random = randomBounded+instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded+instance Random CLLong     where randomR = randomIvalIntegral; random = randomBounded+instance Random CULLong    where randomR = randomIvalIntegral; random = randomBounded+instance Random CIntPtr    where randomR = randomIvalIntegral; random = randomBounded+instance Random CUIntPtr   where randomR = randomIvalIntegral; random = randomBounded+instance Random CIntMax    where randomR = randomIvalIntegral; random = randomBounded+instance Random CUIntMax   where randomR = randomIvalIntegral; random = randomBounded++instance Random Char where+  randomR (a,b) g = +       case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of+         (x,g') -> (chr x, g')+  random g	  = randomR (minBound,maxBound) g++instance Random Bool where+  randomR (a,b) g = +      case (randomIvalInteger (bool2Int a, bool2Int b) g) of+        (x, g') -> (int2Bool x, g')+       where+         bool2Int :: Bool -> Integer+         bool2Int False = 0+         bool2Int True  = 1++	 int2Bool :: Int -> Bool+	 int2Bool 0	= False+	 int2Bool _	= True++  random g	  = randomR (minBound,maxBound) g++{-# INLINE randomRFloating #-}+randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g)+randomRFloating (l,h) g +    | l>h       = randomRFloating (h,l) g+    | otherwise = let (coef,g') = random g in +		  (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g')  -- avoid overflow++instance Random Double where+  randomR = randomRFloating+  random rng     = +    case random rng of +      (x,rng') -> +          -- We use 53 bits of randomness corresponding to the 53 bit significand:+          ((fromIntegral (mask53 .&. (x::Int64)) :: Double)  +	   /  fromIntegral twoto53, rng')+   where +    twoto53 = (2::Int64) ^ (53::Int64)+    mask53 = twoto53 - 1+ +instance Random Float where+  randomR = randomRFloating+  random rng = +    -- TODO: Faster to just use 'next' IF it generates enough bits of randomness.   +    case random rng of +      (x,rng') -> +          -- We use 24 bits of randomness corresponding to the 24 bit significand:+          ((fromIntegral (mask24 .&. (x::Int32)) :: Float) +	   /  fromIntegral twoto24, rng')+	 -- Note, encodeFloat is another option, but I'm not seeing slightly+	 --  worse performance with the following [2011.06.25]:+--         (encodeFloat rand (-24), rng')+   where+     mask24 = twoto24 - 1+     twoto24 = (2::Int32) ^ (24::Int32)++-- CFloat/CDouble are basically the same as a Float/Double:+instance Random CFloat where+  randomR = randomRFloating+  random rng = case random rng of +  	         (x,rng') -> (realToFrac (x::Float), rng')++instance Random CDouble where+  randomR = randomRFloating+  -- A MYSTERY:+  -- Presently, this is showing better performance than the Double instance:+  -- (And yet, if the Double instance uses randomFrac then its performance is much worse!)+  random  = randomFrac+  -- random rng = case random rng of +  -- 	         (x,rng') -> (realToFrac (x::Double), rng')++mkStdRNG :: Integer -> IO StdGen+mkStdRNG o = do+    ct          <- getCPUTime+    (sec, psec) <- getTime+    return (createStdGen (sec * 12345 + psec + ct + o))++randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g)+randomBounded = randomR (minBound, maxBound)++-- The two integer functions below take an [inclusive,inclusive] range.+randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)+randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h)++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l,h) rng+ | l > h     = randomIvalInteger (h,l) rng+ | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')+     where+       k = h - l + 1+       -- ERROR: b here (2^31-87) represents a baked-in assumption about genRange:+       b = 2147483561+       n = iLogBase b k++       -- Here we loop until we've generated enough randomness to cover the range:+       f 0 acc g = (acc, g)+       f n' acc g =+          let+	   (x,g')   = next g+	  in+          -- We shift over the random bits generated thusfar (* b) and add in the new ones.+	  f (n' - 1) (fromIntegral x + acc * b) g'++-- The continuous functions on the other hand take an [inclusive,exclusive) range.+randomFrac :: (RandomGen g, Fractional a) => g -> (a, g)+randomFrac = randomIvalDouble (0::Double,1) realToFrac++randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)+randomIvalDouble (l,h) fromDouble rng +  | l > h     = randomIvalDouble (h,l) fromDouble rng+  | otherwise = +       case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of+         (x, rng') -> +	    let+	     scaled_x = +		fromDouble (0.5*l + 0.5*h) +                   -- previously (l+h)/2, overflowed+                fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) *  -- avoid overflow+		fromIntegral (x::Int32)+	    in+	    (scaled_x, rng')++int32Count :: Integer+int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1++-- Perform an expensive logarithm on arbitrary-size integers by repeated division.+-- +-- (NOTE: This actually returns ceiling(log(i) base b) except with an+--  incorrect result at iLogBase b b = 2.)+iLogBase :: Integer -> Integer -> Integer+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)++stdRange :: (Int,Int)+stdRange = (0, 2147483562)++stdNext :: StdGen -> (Int, StdGen)+-- Returns values in the range stdRange+stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'')+	where	z'   = if z < 1 then z + 2147483562 else z+		z    = s1'' - s2''++		k    = s1 `quot` 53668+		s1'  = 40014 * (s1 - k * 53668) - k * 12211+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'+    +		k'   = s2 `quot` 52774+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'++stdSplit            :: StdGen -> (StdGen, StdGen)+stdSplit std@(StdGen s1 s2)+                     = (left, right)+                       where+                        -- no statistical foundation for this!+                        left    = StdGen new_s1 t2+                        right   = StdGen t1 new_s2++                        new_s1 | s1 == 2147483562 = 1+                               | otherwise        = s1 + 1++                        new_s2 | s2 == 1          = 2147483398+                               | otherwise        = s2 - 1++                        StdGen t1 t2 = snd (next std)++-- The global random number generator++{- $globalrng #globalrng#++There is a single, implicit, global random number generator of type+'StdGen', held in some global variable maintained by the 'IO' monad. It is+initialised automatically in some system-dependent fashion, for example, by+using the time of day, or Linux's kernel random number generator. To get+deterministic behaviour, use 'setStdGen'.+-}++-- |Sets the global random number generator.+setStdGen :: StdGen -> IO ()+setStdGen sgen = writeIORef theStdGen sgen++-- |Gets the global random number generator.+getStdGen :: IO StdGen+getStdGen  = readIORef theStdGen++theStdGen :: IORef StdGen+theStdGen  = unsafePerformIO $ do+   rng <- mkStdRNG 0+   newIORef rng++-- |Applies 'split' to the current global random generator,+-- updates it with one of the results, and returns the other.+newStdGen :: IO StdGen+newStdGen = atomicModifyIORef theStdGen split++{- |Uses the supplied function to get a value from the current global+random generator, and updates the global generator with the new generator+returned by the function. For example, @rollDice@ gets a random integer+between 1 and 6:++>  rollDice :: IO Int+>  rollDice = getStdRandom (randomR (1,6))++-}++getStdRandom :: (StdGen -> (a,StdGen)) -> IO a+getStdRandom f = atomicModifyIORef theStdGen (swap . f)+  where swap (v,g) = (g,v)++{- $references++1. FW #Burton# Burton and RL Page, /Distributed random number generation/,+Journal of Functional Programming, 2(2):203-212, April 1992.++2. SK #Park# Park, and KW Miller, /Random number generators -+good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201.++3. DG #Carta# Carta, /Two fast implementations of the minimal standard+random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88.++4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/,+Department of Mathematics, University of Salzburg,+<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998.++5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random+number generators/, Comm ACM, 31(6), Jun 1988, pp742-749.++The Web site <http://random.mat.sbg.ac.at/> is a great source of information.++-}
+ Text/Parsec.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-----------------------------------------------------------------------------++module Text.Parsec+    ( module Text.Parsec.Prim+    , module Text.Parsec.Char+    , module Text.Parsec.Combinator+    , module Text.Parsec.String+    , module Text.Parsec.ByteString+    , module Text.Parsec.ByteString.Lazy+    , ParseError+    , errorPos+    , SourcePos+    , SourceName, Line, Column+    , sourceName, sourceLine, sourceColumn+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName+    ) where++import Text.Parsec.Pos+import Text.Parsec.Error+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.String           hiding ( Parser, GenParser, parseFromFile )+import Text.Parsec.ByteString       hiding ( Parser, GenParser, parseFromFile )+import Text.Parsec.ByteString.Lazy  hiding ( Parser, GenParser, parseFromFile )
+ Text/Parsec/ByteString.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.ByteString+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make strict ByteStrings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.ByteString+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++import qualified Data.ByteString.Char8 as C++instance (Monad m) => Stream C.ByteString m Char where+    uncons = return . C.uncons++type Parser = Parsec C.ByteString ()+type GenParser t st = Parsec C.ByteString st++-- | @parseFromFile p filePath@ runs a strict bytestring parser @p@ on the+-- input read from @filePath@ using 'ByteString.Char8.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }++parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- C.readFile fname+         return (runP p () fname input)
+ Text/Parsec/ByteString/Lazy.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.ByteString.Lazy+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Make lazy ByteStrings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.ByteString.Lazy+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++import qualified Data.ByteString.Lazy.Char8 as C++instance (Monad m) => Stream C.ByteString m Char where+    uncons = return . C.uncons++type Parser = Parsec C.ByteString ()+type GenParser t st = Parsec C.ByteString st++-- | @parseFromFile p filePath@ runs a lazy bytestring parser @p@ on the+-- input read from @filePath@ using 'ByteString.Lazy.Char8.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }+parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- C.readFile fname+         return (runP p () fname input)
+ Text/Parsec/Char.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Char+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Commonly used character parsers.+-- +-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Text.Parsec.Char where++import Data.Char+import Text.Parsec.Pos+import Text.Parsec.Prim++-- | @oneOf cs@ succeeds if the current character is in the supplied+-- list of characters @cs@. Returns the parsed character. See also+-- 'satisfy'.+-- +-- >   vowel  = oneOf "aeiou"++oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char+oneOf cs            = satisfy (\c -> elem c cs)++-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current+-- character /not/ in the supplied list of characters @cs@. Returns the+-- parsed character.+--+-- >  consonant = noneOf "aeiou"++noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char+noneOf cs           = satisfy (\c -> not (elem c cs))++-- | Skips /zero/ or more white space characters. See also 'skipMany'.++spaces :: (Stream s m Char) => ParsecT s u m ()+spaces              = skipMany space        <?> "white space"++-- | Parses a white space character (any character which satisfies 'isSpace')+-- Returns the parsed character. ++space :: (Stream s m Char) => ParsecT s u m Char+space               = satisfy isSpace       <?> "space"++-- | Parses a newline character (\'\\n\'). Returns a newline character. ++newline :: (Stream s m Char) => ParsecT s u m Char+newline             = char '\n'             <?> "new-line"++-- | Parses a tab character (\'\\t\'). Returns a tab character. ++tab :: (Stream s m Char) => ParsecT s u m Char+tab                 = char '\t'             <?> "tab"++-- | Parses an upper case letter (a character between \'A\' and \'Z\').+-- Returns the parsed character. ++upper :: (Stream s m Char) => ParsecT s u m Char+upper               = satisfy isUpper       <?> "uppercase letter"++-- | Parses a lower case character (a character between \'a\' and \'z\').+-- Returns the parsed character. ++lower :: (Stream s m Char) => ParsecT s u m Char+lower               = satisfy isLower       <?> "lowercase letter"++-- | Parses a letter or digit (a character between \'0\' and \'9\').+-- Returns the parsed character. ++alphaNum :: (Stream s m Char => ParsecT s u m Char)+alphaNum            = satisfy isAlphaNum    <?> "letter or digit"++-- | Parses a letter (an upper case or lower case character). Returns the+-- parsed character. ++letter :: (Stream s m Char) => ParsecT s u m Char+letter              = satisfy isAlpha       <?> "letter"++-- | Parses a digit. Returns the parsed character. ++digit :: (Stream s m Char) => ParsecT s u m Char+digit               = satisfy isDigit       <?> "digit"++-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and+-- \'f\' or \'A\' and \'F\'). Returns the parsed character. ++hexDigit :: (Stream s m Char) => ParsecT s u m Char+hexDigit            = satisfy isHexDigit    <?> "hexadecimal digit"++-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns+-- the parsed character. ++octDigit :: (Stream s m Char) => ParsecT s u m Char+octDigit            = satisfy isOctDigit    <?> "octal digit"++-- | @char c@ parses a single character @c@. Returns the parsed+-- character (i.e. @c@).+--+-- >  semiColon  = char ';'++char :: (Stream s m Char) => Char -> ParsecT s u m Char+char c              = satisfy (==c)  <?> show [c]++-- | This parser succeeds for any character. Returns the parsed character. ++anyChar :: (Stream s m Char) => ParsecT s u m Char+anyChar             = satisfy (const True)++-- | The parser @satisfy f@ succeeds for any character for which the+-- supplied function @f@ returns 'True'. Returns the character that is+-- actually parsed.++-- >  digit     = satisfy isDigit+-- >  oneOf cs  = satisfy (\c -> c `elem` cs)++satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char+satisfy f           = tokenPrim (\c -> show [c])+                                (\pos c _cs -> updatePosChar pos c)+                                (\c -> if f c then Just c else Nothing)++-- | @string s@ parses a sequence of characters given by @s@. Returns+-- the parsed string (i.e. @s@).+--+-- >  divOrMod    =   string "div" +-- >              <|> string "mod"++string :: (Stream s m Char) => String -> ParsecT s u m String+string s            = tokens show updatePosString s
+ Text/Parsec/Combinator.hs view
@@ -0,0 +1,277 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Combinator+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Commonly used generic combinators+-- +-----------------------------------------------------------------------------++module Text.Parsec.Combinator+    ( choice+    , count+    , between+    , option, optionMaybe, optional+    , skipMany1+    , many1+    , sepBy, sepBy1+    , endBy, endBy1+    , sepEndBy, sepEndBy1+    , chainl, chainl1+    , chainr, chainr1+    , eof, notFollowedBy+    -- tricky combinators+    , manyTill, lookAhead, anyToken+    ) where++import Control.Monad+import Text.Parsec.Prim++-- | @choice ps@ tries to apply the parsers in the list @ps@ in order,+-- until one of them succeeds. Returns the value of the succeeding+-- parser.++choice :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a+choice ps           = foldr (<|>) mzero ps++-- | @option x p@ tries to apply parser @p@. If @p@ fails without+-- consuming input, it returns the value @x@, otherwise the value+-- returned by @p@.+--+-- >  priority  = option 0 (do{ d <- digit+-- >                          ; return (digitToInt d) +-- >                          })++option :: (Stream s m t) => a -> ParsecT s u m a -> ParsecT s u m a+option x p          = p <|> return x++-- | @optionMaybe p@ tries to apply parser @p@.  If @p@ fails without+-- consuming input, it return 'Nothing', otherwise it returns+-- 'Just' the value returned by @p@.++optionMaybe :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (Maybe a)+optionMaybe p       = option Nothing (liftM Just p)++-- | @optional p@ tries to apply parser @p@.  It will parse @p@ or nothing.+-- It only fails if @p@ fails after consuming input. It discards the result+-- of @p@.++optional :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()+optional p          = do{ p; return ()} <|> return ()++-- | @between open close p@ parses @open@, followed by @p@ and @close@.+-- Returns the value returned by @p@.+--+-- >  braces  = between (symbol "{") (symbol "}")++between :: (Stream s m t) => ParsecT s u m open -> ParsecT s u m close+            -> ParsecT s u m a -> ParsecT s u m a+between open close p+                    = do{ open; x <- p; close; return x }++-- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping+-- its result. ++skipMany1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()+skipMany1 p         = do{ p; skipMany p }+{-+skipMany p          = scan+                    where+                      scan  = do{ p; scan } <|> return ()+-}++-- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a+-- list of the returned values of @p@.+--+-- >  word  = many1 letter++many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]+many1 p             = do{ x <- p; xs <- many p; return (x:xs) }+{-+many p              = scan id+                    where+                      scan f    = do{ x <- p+                                    ; scan (\tail -> f (x:tail))+                                    }+                                <|> return (f [])+-}+++-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of values returned by @p@.+--+-- >  commaSep p  = p `sepBy` (symbol ",")++sepBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepBy p sep         = sepBy1 p sep <|> return []++-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of values returned by @p@. ++sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepBy1 p sep        = do{ x <- p+                        ; xs <- many (sep >> p)+                        ; return (x:xs)+                        }+++-- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@,+-- separated and optionally ended by @sep@. Returns a list of values+-- returned by @p@. ++sepEndBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepEndBy1 p sep     = do{ x <- p+                        ; do{ sep+                            ; xs <- sepEndBy p sep+                            ; return (x:xs)+                            }+                          <|> return [x]+                        }++-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@,+-- separated and optionally ended by @sep@, ie. haskell style+-- statements. Returns a list of values returned by @p@.+--+-- >  haskellStatements  = haskellStatement `sepEndBy` semi++sepEndBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepEndBy p sep      = sepEndBy1 p sep <|> return []+++-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated+-- and ended by @sep@. Returns a list of values returned by @p@. ++endBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+endBy1 p sep        = many1 (do{ x <- p; sep; return x })++-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated+-- and ended by @sep@. Returns a list of values returned by @p@.+--+-- >   cStatements  = cStatement `endBy` semi++endBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+endBy p sep         = many (do{ x <- p; sep; return x })++-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or+-- equal to zero, the parser equals to @return []@. Returns a list of+-- @n@ values returned by @p@. ++count :: (Stream s m t) => Int -> ParsecT s u m a -> ParsecT s u m [a]+count n p           | n <= 0    = return []+                    | otherwise = sequence (replicate n p)++-- | @chainr p op x@ parser /zero/ or more occurrences of @p@,+-- separated by @op@ Returns a value obtained by a /right/ associative+-- application of all functions returned by @op@ to the values returned+-- by @p@. If there are no occurrences of @p@, the value @x@ is+-- returned.++chainr :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a+chainr p op x       = chainr1 p op <|> return x++-- | @chainl p op x@ parser /zero/ or more occurrences of @p@,+-- separated by @op@. Returns a value obtained by a /left/ associative+-- application of all functions returned by @op@ to the values returned+-- by @p@. If there are zero occurrences of @p@, the value @x@ is+-- returned.++chainl :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a+chainl p op x       = chainl1 p op <|> return x++-- | @chainl1 p op x@ parser /one/ or more occurrences of @p@,+-- separated by @op@ Returns a value obtained by a /left/ associative+-- application of all functions returned by @op@ to the values returned+-- by @p@. . This parser can for example be used to eliminate left+-- recursion which typically occurs in expression grammars.+--+-- >  expr    = term   `chainl1` addop+-- >  term    = factor `chainl1` mulop+-- >  factor  = parens expr <|> integer+-- >+-- >  mulop   =   do{ symbol "*"; return (*)   }+-- >          <|> do{ symbol "/"; return (div) }+-- >+-- >  addop   =   do{ symbol "+"; return (+) }+-- >          <|> do{ symbol "-"; return (-) }++chainl1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a+chainl1 p op        = do{ x <- p; rest x }+                    where+                      rest x    = do{ f <- op+                                    ; y <- p+                                    ; rest (f x y)+                                    }+                                <|> return x++-- | @chainr1 p op x@ parser /one/ or more occurrences of |p|,+-- separated by @op@ Returns a value obtained by a /right/ associative+-- application of all functions returned by @op@ to the values returned+-- by @p@.++chainr1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a+chainr1 p op        = scan+                    where+                      scan      = do{ x <- p; rest x }++                      rest x    = do{ f <- op+                                    ; y <- scan+                                    ; return (f x y)+                                    }+                                <|> return x++-----------------------------------------------------------+-- Tricky combinators+-----------------------------------------------------------+-- | The parser @anyToken@ accepts any kind of token. It is for example+-- used to implement 'eof'. Returns the accepted token. ++anyToken :: (Stream s m t, Show t) => ParsecT s u m t+anyToken            = tokenPrim show (\pos _tok _toks -> pos) Just++-- | This parser only succeeds at the end of the input. This is not a+-- primitive parser but it is defined using 'notFollowedBy'.+--+-- >  eof  = notFollowedBy anyToken <?> "end of input"++eof :: (Stream s m t, Show t) => ParsecT s u m ()+eof                 = notFollowedBy anyToken <?> "end of input"++-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser+-- does not consume any input. This parser can be used to implement the+-- \'longest match\' rule. For example, when recognizing keywords (for+-- example @let@), we want to make sure that a keyword is not followed+-- by a legal identifier character, in which case the keyword is+-- actually an identifier (for example @lets@). We can program this+-- behaviour as follows:+--+-- >  keywordLet  = try (do{ string "let"+-- >                       ; notFollowedBy alphaNum+-- >                       })++notFollowedBy :: (Stream s m t, Show a) => ParsecT s u m a -> ParsecT s u m ()+notFollowedBy p     = try (do{ c <- try p; unexpected (show c) }+                           <|> return ()+                          )++-- | @manyTill p end@ applies parser @p@ /zero/ or more times until+-- parser @end@ succeeds. Returns the list of values returned by @p@.+-- This parser can be used to scan comments:+--+-- >  simpleComment   = do{ string "<!--"+-- >                      ; manyTill anyChar (try (string "-->"))+-- >                      }+--+--    Note the overlapping parsers @anyChar@ and @string \"-->\"@, and+--    therefore the use of the 'try' combinator.++manyTill :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]+manyTill p end      = scan+                    where+                      scan  = do{ end; return [] }+                            <|>+                              do{ x <- p; xs <- scan; return (x:xs) }
+ Text/Parsec/Error.hs view
@@ -0,0 +1,201 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Error+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parse errors+-- +-----------------------------------------------------------------------------++module Text.Parsec.Error+    ( Message ( SysUnExpect, UnExpect, Expect, Message )+    , messageString+    , ParseError, errorPos, errorMessages, errorIsUnknown+    , showErrorMessages+    , newErrorMessage, newErrorUnknown+    , addErrorMessage, setErrorPos, setErrorMessage+    , mergeError+    ) where++import Data.List ( nub, sort )++import Text.Parsec.Pos++-- | This abstract data type represents parse error messages. There are+-- four kinds of messages:+--+-- >  data Message = SysUnExpect String+-- >               | UnExpect String+-- >               | Expect String+-- >               | Message String+-- +-- The fine distinction between different kinds of parse errors allows+-- the system to generate quite good error messages for the user. It+-- also allows error messages that are formatted in different+-- languages. Each kind of message is generated by different combinators:+--+--     * A 'SysUnExpect' message is automatically generated by the+--       'Text.Parsec.Combinator.satisfy' combinator. The argument is the+--       unexpected input.+--+--     * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected'+--       combinator. The argument describes the+--       unexpected item.+--+--     * A 'Expect' message is generated by the 'Text.Parsec.Prim.<?>'+--       combinator. The argument describes the expected item.+--+--     * A 'Message' message is generated by the 'fail'+--       combinator. The argument is some general parser message. ++data Message = SysUnExpect !String -- @ library generated unexpect+             | UnExpect    !String -- @ unexpected something+             | Expect      !String -- @ expecting something+             | Message     !String -- @ raw message++instance Enum Message where+    fromEnum (SysUnExpect _) = 0+    fromEnum (UnExpect    _) = 1+    fromEnum (Expect      _) = 2+    fromEnum (Message     _) = 3+    toEnum _ = error "toEnum is undefined for Message"++-- < Return 'True' only when 'compare' would return 'EQ'.++instance Eq Message where++    m1 == m2 = fromEnum m1 == fromEnum m2++-- < Compares two error messages without looking at their content. Only+-- the constructors are compared where:+-- +-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message'++instance Ord Message where+    compare msg1 msg2 = compare (fromEnum msg1) (fromEnum msg2)++-- | Extract the message string from an error message ++messageString :: Message -> String+messageString (SysUnExpect s) = s+messageString (UnExpect    s) = s+messageString (Expect      s) = s+messageString (Message     s) = s++-- | The abstract data type @ParseError@ represents parse errors. It+-- provides the source position ('SourcePos') of the error+-- and a list of error messages ('Message'). A @ParseError@+-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an+-- instance of the 'Show' class. ++data ParseError = ParseError !SourcePos [Message]++-- | Extracts the source position from the parse error++errorPos :: ParseError -> SourcePos+errorPos (ParseError pos _msgs)+    = pos++-- | Extracts the list of error messages from the parse error++errorMessages :: ParseError -> [Message]+errorMessages (ParseError _pos msgs)+    = sort msgs++errorIsUnknown :: ParseError -> Bool+errorIsUnknown (ParseError _pos msgs)+    = null msgs++-- < Create parse errors++newErrorUnknown :: SourcePos -> ParseError+newErrorUnknown pos+    = ParseError pos []++newErrorMessage :: Message -> SourcePos -> ParseError+newErrorMessage msg pos+    = ParseError pos [msg]++addErrorMessage :: Message -> ParseError -> ParseError+addErrorMessage msg (ParseError pos msgs)+    = ParseError pos (msg:msgs)++setErrorPos :: SourcePos -> ParseError -> ParseError+setErrorPos pos (ParseError _ msgs)+    = ParseError pos msgs++setErrorMessage :: Message -> ParseError -> ParseError+setErrorMessage msg (ParseError pos msgs)+    = ParseError pos (msg : filter (msg /=) msgs)++mergeError :: ParseError -> ParseError -> ParseError+mergeError (ParseError pos1 msgs1) (ParseError pos2 msgs2)+    = case pos1 `compare` pos2 of+        -- select the longest match+        EQ -> ParseError pos1 (msgs1 ++ msgs2)+        GT -> ParseError pos1 msgs1+        LT -> ParseError pos2 msgs2++instance Show ParseError where+    show err+        = show (errorPos err) ++ ":" +++          showErrorMessages "or" "unknown parse error"+                            "expecting" "unexpected" "end of input"+                           (errorMessages err)++-- Language independent show function++--  TODO+-- < The standard function for showing error messages. Formats a list of+--    error messages in English. This function is used in the |Show|+--    instance of |ParseError <#ParseError>|. The resulting string will be+--    formatted like:+--+--    |unexpected /{The first UnExpect or a SysUnExpect message}/;+--    expecting /{comma separated list of Expect messages}/;+--    /{comma separated list of Message messages}/++showErrorMessages ::+    String -> String -> String -> String -> String -> [Message] -> String+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs+    | null msgs = msgUnknown+    | otherwise = concat $ map ("\n"++) $ clean $+                 [showSysUnExpect,showUnExpect,showExpect,showMessages]+    where+      (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs+      (unExpect,msgs2)    = span ((UnExpect    "") ==) msgs1+      (expect,messages)   = span ((Expect      "") ==) msgs2++      showExpect      = showMany msgExpecting expect+      showUnExpect    = showMany msgUnExpected unExpect+      showSysUnExpect | not (null unExpect) ||+                        null sysUnExpect = ""+                      | null firstMsg    = msgUnExpected ++ " " ++ msgEndOfInput+                      | otherwise        = msgUnExpected ++ " " ++ firstMsg+          where+              firstMsg  = messageString (head sysUnExpect)++      showMessages      = showMany "" messages++      -- helpers+      showMany pre msgs = case clean (map messageString msgs) of+                            [] -> ""+                            ms | null pre  -> commasOr ms+                               | otherwise -> pre ++ " " ++ commasOr ms++      commasOr []       = ""+      commasOr [m]      = m+      commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms++      commaSep          = seperate ", " . clean++      seperate   _ []     = ""+      seperate   _ [m]    = m+      seperate sep (m:ms) = m ++ sep ++ seperate sep ms++      clean             = nub . filter (not . null)
+ Text/Parsec/Expr.hs view
@@ -0,0 +1,166 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Expr+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-- A helper module to parse \"expressions\".+-- Builds a parser given a table of operators and associativities.+-- +-----------------------------------------------------------------------------++module Text.Parsec.Expr+    ( Assoc(..), Operator(..), OperatorTable+    , buildExpressionParser+    ) where++import Text.Parsec.Prim+import Text.Parsec.Combinator++-----------------------------------------------------------+-- Assoc and OperatorTable+-----------------------------------------------------------++-- |  This data type specifies the associativity of operators: left, right+-- or none.++data Assoc                = AssocNone+                          | AssocLeft+                          | AssocRight++-- | This data type specifies operators that work on values of type @a@.+-- An operator is either binary infix or unary prefix or postfix. A+-- binary operator has also an associated associativity.++data Operator s u m a   = Infix (ParsecT s u m (a -> a -> a)) Assoc+                        | Prefix (ParsecT s u m (a -> a))+                        | Postfix (ParsecT s u m (a -> a))++-- | An @OperatorTable s u m a@ is a list of @Operator s u m a@+-- lists. The list is ordered in descending+-- precedence. All operators in one list have the same precedence (but+-- may have a different associativity).++type OperatorTable s u m a = [[Operator s u m a]]++-----------------------------------------------------------+-- Convert an OperatorTable and basic term parser into+-- a full fledged expression parser+-----------------------------------------------------------++-- | @buildExpressionParser table term@ builds an expression parser for+-- terms @term@ with operators from @table@, taking the associativity+-- and precedence specified in @table@ into account. Prefix and postfix+-- operators of the same precedence can only occur once (i.e. @--2@ is+-- not allowed if @-@ is prefix negate). Prefix and postfix operators+-- of the same precedence associate to the left (i.e. if @++@ is+-- postfix increment, than @-2++@ equals @-1@, not @-3@).+--+-- The @buildExpressionParser@ takes care of all the complexity+-- involved in building expression parser. Here is an example of an+-- expression parser that handles prefix signs, postfix increment and+-- basic arithmetic.+--+-- >  expr    = buildExpressionParser table term+-- >          <?> "expression"+-- >+-- >  term    =  parens expr +-- >          <|> natural+-- >          <?> "simple expression"+-- >+-- >  table   = [ [prefix "-" negate, prefix "+" id ]+-- >            , [postfix "++" (+1)]+-- >            , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]+-- >            , [binary "+" (+) AssocLeft, binary "-" (-)   AssocLeft ]+-- >            ]+-- >          +-- >  binary  name fun assoc = Infix (do{ reservedOp name; return fun }) assoc+-- >  prefix  name fun       = Prefix (do{ reservedOp name; return fun })+-- >  postfix name fun       = Postfix (do{ reservedOp name; return fun })++buildExpressionParser :: (Stream s m t)+                      => OperatorTable s u m a+                      -> ParsecT s u m a+                      -> ParsecT s u m a+buildExpressionParser operators simpleExpr+    = foldl (makeParser) simpleExpr operators+    where+      makeParser term ops+        = let (rassoc,lassoc,nassoc+               ,prefix,postfix)      = foldr splitOp ([],[],[],[],[]) ops++              rassocOp   = choice rassoc+              lassocOp   = choice lassoc+              nassocOp   = choice nassoc+              prefixOp   = choice prefix  <?> ""+              postfixOp  = choice postfix <?> ""++              ambigious assoc op= try $+                                  do{ op; fail ("ambiguous use of a " ++ assoc+                                                 ++ " associative operator")+                                    }++              ambigiousRight    = ambigious "right" rassocOp+              ambigiousLeft     = ambigious "left" lassocOp+              ambigiousNon      = ambigious "non" nassocOp++              termP      = do{ pre  <- prefixP+                             ; x    <- term+                             ; post <- postfixP+                             ; return (post (pre x))+                             }++              postfixP   = postfixOp <|> return id++              prefixP    = prefixOp <|> return id++              rassocP x  = do{ f <- rassocOp+                             ; y  <- do{ z <- termP; rassocP1 z }+                             ; return (f x y)+                             }+                           <|> ambigiousLeft+                           <|> ambigiousNon+                           -- <|> return x++              rassocP1 x = rassocP x  <|> return x++              lassocP x  = do{ f <- lassocOp+                             ; y <- termP+                             ; lassocP1 (f x y)+                             }+                           <|> ambigiousRight+                           <|> ambigiousNon+                           -- <|> return x++              lassocP1 x = lassocP x <|> return x++              nassocP x  = do{ f <- nassocOp+                             ; y <- termP+                             ;    ambigiousRight+                              <|> ambigiousLeft+                              <|> ambigiousNon+                              <|> return (f x y)+                             }+                           -- <|> return x++           in  do{ x <- termP+                 ; rassocP x <|> lassocP  x <|> nassocP x <|> return x+                   <?> "operator"+                 }+++      splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix)+        = case assoc of+            AssocNone  -> (rassoc,lassoc,op:nassoc,prefix,postfix)+            AssocLeft  -> (rassoc,op:lassoc,nassoc,prefix,postfix)+            AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix)++      splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix)+        = (rassoc,lassoc,nassoc,op:prefix,postfix)++      splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix)+        = (rassoc,lassoc,nassoc,prefix,op:postfix)
+ Text/Parsec/Language.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Language+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses non-portable module Text.Parsec.Token)+--+-- A helper module that defines some language definitions that can be used+-- to instantiate a token parser (see "Text.Parsec.Token").+-- +-----------------------------------------------------------------------------++module Text.Parsec.Language+    ( haskellDef, haskell+    , mondrianDef, mondrian+    , emptyDef+    , haskellStyle+    , javaStyle+    , LanguageDef+    , GenLanguageDef+    ) where++import Text.Parsec+import Text.Parsec.Token++-----------------------------------------------------------+-- Styles: haskellStyle, javaStyle+-----------------------------------------------------------++-- | This is a minimal token definition for Haskell style languages. It+-- defines the style of comments, valid identifiers and case+-- sensitivity. It does not define any reserved words or operators.++haskellStyle :: LanguageDef st+haskellStyle = emptyDef+                { commentStart   = "{-"+                , commentEnd     = "-}"+                , commentLine    = "--"+                , nestedComments = True+                , identStart     = letter+                , identLetter	 = alphaNum <|> oneOf "_'"+                , opStart	 = opLetter haskellStyle+                , opLetter	 = oneOf ":!#$%&*+./<=>?@\\^|-~"+                , reservedOpNames= []+                , reservedNames  = []+                , caseSensitive  = True+                }++-- | This is a minimal token definition for Java style languages. It+-- defines the style of comments, valid identifiers and case+-- sensitivity. It does not define any reserved words or operators.++javaStyle  :: LanguageDef st+javaStyle   = emptyDef+		{ commentStart	 = "/*"+		, commentEnd	 = "*/"+		, commentLine	 = "//"+		, nestedComments = True+		, identStart	 = letter+		, identLetter	 = alphaNum <|> oneOf "_'"+		, reservedNames  = []+		, reservedOpNames= []+                , caseSensitive  = False+		}++-----------------------------------------------------------+-- minimal language definition+--------------------------------------------------------++-- TODO: This seems wrong+-- < This is the most minimal token definition. It is recommended to use+-- this definition as the basis for other definitions. @emptyDef@ has+-- no reserved names or operators, is case sensitive and doesn't accept+-- comments, identifiers or operators.++emptyDef   :: LanguageDef st+emptyDef    = LanguageDef+               { commentStart   = ""+               , commentEnd     = ""+               , commentLine    = ""+               , nestedComments = True+               , identStart     = letter <|> char '_'+               , identLetter    = alphaNum <|> oneOf "_'"+               , opStart        = opLetter emptyDef+               , opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"+               , reservedOpNames= []+               , reservedNames  = []+               , caseSensitive  = True+               }++++-----------------------------------------------------------+-- Haskell+-----------------------------------------------------------++-- | A lexer for the haskell language.++haskell :: TokenParser st+haskell      = makeTokenParser haskellDef++-- | The language definition for the Haskell language.++haskellDef  :: LanguageDef st+haskellDef   = haskell98Def+	        { identLetter	 = identLetter haskell98Def <|> char '#'+	        , reservedNames	 = reservedNames haskell98Def +++    				   ["foreign","import","export","primitive"+    				   ,"_ccall_","_casm_"+    				   ,"forall"+    				   ]+                }++-- | The language definition for the language Haskell98.++haskell98Def :: LanguageDef st+haskell98Def = haskellStyle+                { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"]+                , reservedNames  = ["let","in","case","of","if","then","else",+                                    "data","type",+                                    "class","default","deriving","do","import",+                                    "infix","infixl","infixr","instance","module",+                                    "newtype","where",+                                    "primitive"+                                    -- "as","qualified","hiding"+                                   ]+                }+++-----------------------------------------------------------+-- Mondrian+-----------------------------------------------------------++-- | A lexer for the mondrian language.++mondrian :: TokenParser st+mondrian    = makeTokenParser mondrianDef++-- | The language definition for the language Mondrian.++mondrianDef :: LanguageDef st+mondrianDef = javaStyle+		{ reservedNames = [ "case", "class", "default", "extends"+				  , "import", "in", "let", "new", "of", "package"+				  ]+                , caseSensitive  = True+		}
+ Text/Parsec/Perm.hs view
@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Perm+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses existentially quantified data constructors)+-- +-- This module implements permutation parsers. The algorithm used+-- is fairly complex since we push the type system to its limits :-)+-- The algorithm is described in:+-- +-- /Parsing Permutation Phrases,/+-- by Arthur Baars, Andres Loh and Doaitse Swierstra.+-- Published as a functional pearl at the Haskell Workshop 2001.+-- +-----------------------------------------------------------------------------++{-# LANGUAGE ExistentialQuantification #-}++module Text.Parsec.Perm+    ( PermParser+    , StreamPermParser -- abstract++    , permute+    , (<||>), (<$$>)+    , (<|?>), (<$?>)+    ) where++import Text.Parsec++import Control.Monad.Identity++infixl 1 <||>, <|?>+infixl 2 <$$>, <$?>+++{---------------------------------------------------------------+  test -- parse a permutation of+  * an optional string of 'a's+  * a required 'b'+  * an optional 'c'+---------------------------------------------------------------}+{-+test input+  = parse (do{ x <- ptest; eof; return x }) "" input++ptest :: Parser (String,Char,Char)+ptest+  = permute $+    (,,) <$?> ("",many1 (char 'a'))+         <||> char 'b'+         <|?> ('_',char 'c')+-}++{---------------------------------------------------------------+  Building a permutation parser+---------------------------------------------------------------}++-- | The expression @perm \<||> p@ adds parser @p@ to the permutation+-- parser @perm@. The parser @p@ is not allowed to accept empty input -+-- use the optional combinator ('<|?>') instead. Returns a+-- new permutation parser that includes @p@. ++(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b+(<||>) perm p     = add perm p++-- | The expression @f \<$$> p@ creates a fresh permutation parser+-- consisting of parser @p@. The the final result of the permutation+-- parser is the function @f@ applied to the return value of @p@. The+-- parser @p@ is not allowed to accept empty input - use the optional+-- combinator ('<$?>') instead.+--+-- If the function @f@ takes more than one parameter, the type variable+-- @b@ is instantiated to a functional type which combines nicely with+-- the adds parser @p@ to the ('<||>') combinator. This+-- results in stylized code where a permutation parser starts with a+-- combining function @f@ followed by the parsers. The function @f@+-- gets its parameters in the order in which the parsers are specified,+-- but actual input can be in any order.++(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b+(<$$>) f p        = newperm f <||> p++-- | The expression @perm \<||> (x,p)@ adds parser @p@ to the+-- permutation parser @perm@. The parser @p@ is optional - if it can+-- not be applied, the default value @x@ will be used instead. Returns+-- a new permutation parser that includes the optional parser @p@. ++(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b+(<|?>) perm (x,p) = addopt perm x p++-- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser+-- consisting of parser @p@. The the final result of the permutation+-- parser is the function @f@ applied to the return value of @p@. The+-- parser @p@ is optional - if it can not be applied, the default value+-- @x@ will be used instead. ++(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b+(<$?>) f (x,p)    = newperm f <|?> (x,p)++{---------------------------------------------------------------+  The permutation tree+---------------------------------------------------------------}++-- | Provided for backwards compatibility.  The tok type is ignored.++type PermParser tok st a = StreamPermParser String st a++-- | The type @StreamPermParser s st a@ denotes a permutation parser that,+-- when converted by the 'permute' function, parses +-- @s@ streams with user state @st@ and returns a value of+-- type @a@ on success.+--+-- Normally, a permutation parser is first build with special operators+-- like ('<||>') and than transformed into a normal parser+-- using 'permute'.++data StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]++-- type Branch st a = StreamBranch String st a++data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)++-- | The parser @permute perm@ parses a permutation of parser described+-- by @perm@. For example, suppose we want to parse a permutation of:+-- an optional string of @a@'s, the character @b@ and an optional @c@.+-- This can be described by:+--+-- >  test  = permute (tuple <$?> ("",many1 (char 'a'))+-- >                         <||> char 'b' +-- >                         <|?> ('_',char 'c'))+-- >        where+-- >          tuple a b c  = (a,b,c)++-- transform a permutation tree into a normal parser+permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a+permute (Perm def xs)+  = choice (map branch xs ++ empty)+  where+    empty+      = case def of+          Nothing -> []+          Just x  -> [return x]++    branch (Branch perm p)+      = do{ x <- p+          ; f <- permute perm+          ; return (f x)+          }++-- build permutation trees+newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)+newperm f+  = Perm (Just f) []++add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b+add perm@(Perm _mf fs) p+  = Perm Nothing (first:map insert fs)+  where+    first   = Branch perm p+    insert (Branch perm' p')+            = Branch (add (mapPerms flip perm') p) p'++addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b+addopt perm@(Perm mf fs) x p+  = Perm (fmap ($ x) mf) (first:map insert fs)+  where+    first   = Branch perm p+    insert (Branch perm' p')+            = Branch (addopt (mapPerms flip perm') x p) p'+++mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b+mapPerms f (Perm x xs)+  = Perm (fmap f x) (map mapBranch xs)+  where+    mapBranch (Branch perm p)+      = Branch (mapPerms (f.) perm) p
+ Text/Parsec/Pos.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Pos+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Textual source positions.+-- +-----------------------------------------------------------------------------++module Text.Parsec.Pos+    ( SourceName, Line, Column+    , SourcePos+    , sourceLine, sourceColumn, sourceName+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName+    , newPos, initialPos+    , updatePosChar, updatePosString+    ) where++#ifdef BASE3+import Data.Generics+#else+import Data.Data (Data)+import Data.Typeable (Typeable)+#endif++-- < Source positions: a file name, a line and a column+-- upper left is (1,1)++type SourceName = String+type Line       = Int+type Column     = Int++-- | The abstract data type @SourcePos@ represents source positions. It+-- contains the name of the source (i.e. file name), a line number and+-- a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and+-- 'Ord' class. ++data SourcePos  = SourcePos SourceName !Line !Column+    deriving ( Eq, Ord, Data, Typeable)++-- | Create a new 'SourcePos' with the given source name,+-- line number and column number.++newPos :: SourceName -> Line -> Column -> SourcePos+newPos name line column+    = SourcePos name line column++-- | Create a new 'SourcePos' with the given source name,+-- and line number and column number set to 1, the upper left.++initialPos :: SourceName -> SourcePos+initialPos name+    = newPos name 1 1++-- | Extracts the name of the source from a source position. ++sourceName :: SourcePos -> SourceName+sourceName (SourcePos name _line _column) = name++-- | Extracts the line number from a source position. ++sourceLine :: SourcePos -> Line+sourceLine (SourcePos _name line _column) = line++-- | Extracts the column number from a source position. ++sourceColumn :: SourcePos -> Column+sourceColumn (SourcePos _name _line column) = column++-- | Increments the line number of a source position. ++incSourceLine :: SourcePos -> Line -> SourcePos+incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column++-- | Increments the column number of a source position. ++incSourceColumn :: SourcePos -> Column -> SourcePos+incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n)++-- | Set the name of the source.++setSourceName :: SourcePos -> SourceName -> SourcePos+setSourceName (SourcePos _name line column) n = SourcePos n line column++-- | Set the line number of a source position. ++setSourceLine :: SourcePos -> Line -> SourcePos+setSourceLine (SourcePos name _line column) n = SourcePos name n column++-- | Set the column number of a source position. ++setSourceColumn :: SourcePos -> Column -> SourcePos+setSourceColumn (SourcePos name line _column) n = SourcePos name line n++-- | The expression @updatePosString pos s@ updates the source position+-- @pos@ by calling 'updatePosChar' on every character in @s@, ie.+-- @foldl updatePosChar pos string@. ++updatePosString :: SourcePos -> String -> SourcePos+updatePosString pos string+    = foldl updatePosChar pos string++-- | Update a source position given a character. If the character is a+-- newline (\'\\n\') or carriage return (\'\\r\') the line number is+-- incremented by 1. If the character is a tab (\'\t\') the column+-- number is incremented to the nearest 8'th column, ie. @column + 8 -+-- ((column-1) \`mod\` 8)@. In all other cases, the column is+-- incremented by 1. ++updatePosChar   :: SourcePos -> Char -> SourcePos+updatePosChar (SourcePos name line column) c+    = case c of+        '\n' -> SourcePos name (line+1) 1+        '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))+        _    -> SourcePos name line (column + 1)++instance Show SourcePos where+  show (SourcePos name line column)+    | null name = showLineColumn+    | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn+    where+      showLineColumn    = "(line " ++ show line +++                          ", column " ++ show column +++                          ")"
+ Text/Parsec/Prim.hs view
@@ -0,0 +1,740 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Prim+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- The primitive parser combinators.+-- +-----------------------------------------------------------------------------   ++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,+             UndecidableInstances #-}++module Text.Parsec.Prim+    ( unknownError+    , sysUnExpectError+    , unexpected+    , ParsecT+    , runParsecT+    , mkPT+    , Parsec+    , Consumed(..)+    , Reply(..)+    , State(..)+    , parsecMap+    , parserReturn+    , parserBind+    , mergeErrorReply+    , parserFail+    , parserZero+    , parserPlus+    , (<?>)+    , (<|>)+    , label+    , labels+    , lookAhead+    , Stream(..)+    , tokens+    , try+    , token+    , tokenPrim+    , tokenPrimEx+    , many+    , skipMany+    , manyAccum+    , runPT+    , runP+    , runParserT+    , runParser+    , parse+    , parseTest+    , getPosition+    , getInput+    , setPosition+    , setInput+    , getParserState+    , setParserState+    , updateParserState+    , getState+    , putState+    , modifyState+    , setState+    , updateState+    ) where++import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )+import Control.Monad()+import Control.Monad.Trans+import Control.Monad.Identity++import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Cont.Class+import Control.Monad.Error.Class++import Text.Parsec.Pos+import Text.Parsec.Error++unknownError :: State s u -> ParseError+unknownError state        = newErrorUnknown (statePos state)++sysUnExpectError :: String -> SourcePos -> Reply s u a+sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)++-- | The parser @unexpected msg@ always fails with an unexpected error+-- message @msg@ without consuming any input.+--+-- The parsers 'fail', ('<?>') and @unexpected@ are the three parsers+-- used to generate error messages. Of these, only ('<?>') is commonly+-- used. For an example of the use of @unexpected@, see the definition+-- of 'Text.Parsec.Combinator.notFollowedBy'.++unexpected :: (Stream s m t) => String -> ParsecT s u m a+unexpected msg+    = ParsecT $ \s _ _ _ eerr ->+      eerr $ newErrorMessage (UnExpect msg) (statePos s)++-- | ParserT monad transformer and Parser type++-- | @ParsecT s u m a@ is a parser with stream type @s@, user state type @u@,+-- underlying monad @m@ and return type @a@.  Parsec is strict in the user state.+-- If this is undesirable, simply used a data type like @data Box a = Box a@ and+-- the state type @Box YourStateType@ to add a level of indirection.++newtype ParsecT s u m a+    = ParsecT {unParser :: forall b .+                 State s u+              -> (a -> State s u -> ParseError -> m b) -- consumed ok+              -> (ParseError -> m b)                   -- consumed err+              -> (a -> State s u -> ParseError -> m b) -- empty ok+              -> (ParseError -> m b)                   -- empty err+              -> m b+             }++-- | Low-level unpacking of the ParsecT type. To run your parser, please look to+-- runPT, runP, runParserT, runParser and other such functions.+runParsecT :: Monad m => ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))+runParsecT p s = unParser p s cok cerr eok eerr+    where cok a s' err = return . Consumed . return $ Ok a s' err+          cerr err = return . Consumed . return $ Error err+          eok a s' err = return . Empty . return $ Ok a s' err+          eerr err = return . Empty . return $ Error err++-- | Low-level creation of the ParsecT type. You really shouldn't have to do this.+mkPT :: Monad m => (State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a+mkPT k = ParsecT $ \s cok cerr eok eerr -> do+           cons <- k s+           case cons of+             Consumed mrep -> do+                       rep <- mrep+                       case rep of+                         Ok x s' err -> cok x s' err+                         Error err -> cerr err+             Empty mrep -> do+                       rep <- mrep+                       case rep of+                         Ok x s' err -> eok x s' err+                         Error err -> eerr err++type Parsec s u = ParsecT s u Identity++data Consumed a  = Consumed a+                 | Empty !a++data Reply s u a = Ok a !(State s u) ParseError+                 | Error ParseError++data State s u = State {+      stateInput :: s,+      statePos   :: !SourcePos,+      stateUser  :: !u+    }++instance Functor Consumed where+    fmap f (Consumed x) = Consumed (f x)+    fmap f (Empty x)    = Empty (f x)++instance Functor (Reply s u) where+    fmap f (Ok x s e) = Ok (f x) s e+    fmap _ (Error e) = Error e -- XXX++instance Functor (ParsecT s u m) where+    fmap f p = parsecMap f p++parsecMap :: (a -> b) -> ParsecT s u m a -> ParsecT s u m b+parsecMap f p+    = ParsecT $ \s cok cerr eok eerr ->+      unParser p s (cok . f) cerr (eok . f) eerr++instance Applicative.Applicative (ParsecT s u m) where+    pure = return+    (<*>) = ap -- TODO: Can this be optimized?++instance Applicative.Alternative (ParsecT s u m) where+    empty = mzero+    (<|>) = mplus++instance Monad (ParsecT s u m) where+    return x = parserReturn x+    p >>= f  = parserBind p f+    fail msg = parserFail msg++instance (MonadIO m) => MonadIO (ParsecT s u m) where+    liftIO = lift . liftIO++instance (MonadReader r m) => MonadReader r (ParsecT s u m) where+    ask = lift ask+    local f p = mkPT $ \s -> local f (runParsecT p s)++-- I'm presuming the user might want a separate, non-backtracking+-- state aside from the Parsec user state.+instance (MonadState s m) => MonadState s (ParsecT s' u m) where+    get = lift get+    put = lift . put++instance (MonadCont m) => MonadCont (ParsecT s u m) where+    callCC f = mkPT $ \s ->+          callCC $ \c ->+          runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s++     where pack s a= Empty $ return (Ok a s (unknownError s))++instance (MonadError e m) => MonadError e (ParsecT s u m) where+    throwError = lift . throwError+    p `catchError` h = mkPT $ \s ->+        runParsecT p s `catchError` \e ->+            runParsecT (h e) s++parserReturn :: a -> ParsecT s u m a+parserReturn x+    = ParsecT $ \s _ _ eok _ ->+      eok x s (unknownError s)++parserBind :: ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b+{-# INLINE parserBind #-}+parserBind m k+  = ParsecT $ \s cok cerr eok eerr ->+    let+        -- consumed-okay case for m+        mcok x s err =+            let+                 -- if (k x) consumes, those go straigt up+                 pcok = cok+                 pcerr = cerr+                                               +                 -- if (k x) doesn't consume input, but is okay,+                 -- we still return in the consumed continuation+                 peok x s err' = cok x s (mergeError err err')++                 -- if (k x) doesn't consume input, but errors,+                 -- we return the error in the 'consumed-error'+                 -- continuation+                 peerr err' = cerr (mergeError err err')+            in  unParser (k x) s pcok pcerr peok peerr                      ++        -- empty-ok case for m+        meok x s err =+            let+                -- in these cases, (k x) can return as empty+                pcok = cok+                peok x s err' = eok x s (mergeError err err')+                pcerr = cerr+                peerr err' = eerr (mergeError err err') +            in  unParser (k x) s pcok pcerr peok peerr+        -- consumed-error case for m+        mcerr = cerr++        -- empty-error case for m+        meerr = eerr++    in unParser m s mcok mcerr meok meerr+++mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a+mergeErrorReply err1 reply -- XXX where to put it?+    = case reply of+        Ok x state err2 -> Ok x state (mergeError err1 err2)+        Error err2      -> Error (mergeError err1 err2)++parserFail :: String -> ParsecT s u m a+parserFail msg+    = ParsecT $ \s _ _ _ eerr ->+      eerr $ newErrorMessage (Message msg) (statePos s)++instance MonadPlus (ParsecT s u m) where+    mzero = parserZero+    mplus p1 p2 = parserPlus p1 p2++-- | @parserZero@ always fails without consuming any input. @parserZero@ is defined+-- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member +-- of the 'Control.Applicative.Applicative' class.++parserZero :: ParsecT s u m a+parserZero+    = ParsecT $ \s _ _ _ eerr ->+      eerr $ unknownError s++parserPlus :: ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a+{-# INLINE parserPlus #-}+parserPlus m n+    = ParsecT $ \s cok cerr eok eerr ->+      let+          meerr err =+              let+                  neok y s' err' = eok y s' (mergeError err err')+                  neerr err' = eerr $ mergeError err err'+              in unParser n s cok cerr neok neerr+      in unParser m s cok cerr eok meerr++instance MonadTrans (ParsecT s u) where+    lift amb = ParsecT $ \s _ _ eok _ -> do+               a <- amb+               eok a s $ unknownError s++infix  0 <?>+infixr 1 <|>++-- | The parser @p <?> msg@ behaves as parser @p@, but whenever the+-- parser @p@ fails /without consuming any input/, it replaces expect+-- error messages with the expect error message @msg@.+--+-- This is normally used at the end of a set alternatives where we want+-- to return an error message in terms of a higher level construct+-- rather than returning all possible characters. For example, if the+-- @expr@ parser from the 'try' example would fail, the error+-- message is: '...: expecting expression'. Without the @(\<?>)@+-- combinator, the message would be like '...: expecting \"let\" or+-- letter', which is less friendly.++(<?>) :: (ParsecT s u m a) -> String -> (ParsecT s u m a)+p <?> msg = label p msg++-- | This combinator implements choice. The parser @p \<|> q@ first+-- applies @p@. If it succeeds, the value of @p@ is returned. If @p@+-- fails /without consuming any input/, parser @q@ is tried. This+-- combinator is defined equal to the 'mplus' member of the 'MonadPlus'+-- class and the ('Control.Applicative.<|>') member of 'Control.Applicative.Alternative'.+--+-- The parser is called /predictive/ since @q@ is only tried when+-- parser @p@ didn't consume any input (i.e.. the look ahead is 1).+-- This non-backtracking behaviour allows for both an efficient+-- implementation of the parser combinators and the generation of good+-- error messages.++(<|>) :: (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a)+p1 <|> p2 = mplus p1 p2++label :: ParsecT s u m a -> String -> ParsecT s u m a+label p msg+  = labels p [msg]++labels :: ParsecT s u m a -> [String] -> ParsecT s u m a+labels p msgs =+    ParsecT $ \s cok cerr eok eerr ->+    let eok' x s' error = eok x s' $ if errorIsUnknown error+                  then error+                  else setExpectErrors error msgs+        eerr' err = eerr $ setExpectErrors err msgs++    in unParser p s cok cerr eok' eerr'++ where+   setExpectErrors err []         = setErrorMessage (Expect "") err+   setExpectErrors err [msg]      = setErrorMessage (Expect msg) err+   setExpectErrors err (msg:msgs)+       = foldr (\msg' err' -> addErrorMessage (Expect msg') err')+         (setErrorMessage (Expect msg) err) msgs++-- TODO: There should be a stronger statement that can be made about this++-- | An instance of @Stream@ has stream type @s@, underlying monad @m@ and token type @t@ determined by the stream+-- +-- Some rough guidelines for a \"correct\" instance of Stream:+--+--    * unfoldM uncons gives the [t] corresponding to the stream+--+--    * A @Stream@ instance is responsible for maintaining the \"position within the stream\" in the stream state @s@.  This is trivial unless you are using the monad in a non-trivial way.++class (Monad m) => Stream s m t | s -> t where+    uncons :: s -> m (Maybe (t,s))++tokens :: (Stream s m t, Eq t)+       => ([t] -> String)      -- Pretty print a list of tokens+       -> (SourcePos -> [t] -> SourcePos)+       -> [t]                  -- List of tokens to parse+       -> ParsecT s u m [t]+{-# INLINE tokens #-}+tokens _ _ []+    = ParsecT $ \s _ _ eok _ ->+      eok [] s $ unknownError s+tokens showTokens nextposs tts@(tok:toks)+    = ParsecT $ \(State input pos u) cok cerr eok eerr -> +    let+        errEof = (setErrorMessage (Expect (showTokens tts))+                  (newErrorMessage (SysUnExpect "") pos))++        errExpect x = (setErrorMessage (Expect (showTokens tts))+                       (newErrorMessage (SysUnExpect (showTokens [x])) pos))++        walk []     rs = ok rs+        walk (t:ts) rs = do+          sr <- uncons rs+          case sr of+            Nothing                 -> cerr $ errEof+            Just (x,xs) | t == x    -> walk ts xs+                        | otherwise -> cerr $ errExpect x++        ok rs = let pos' = nextposs pos tts+                    s' = State rs pos' u+                in cok tts s' (newErrorUnknown pos')+    in do+        sr <- uncons input+        case sr of+            Nothing         -> eerr $ errEof+            Just (x,xs)+                | tok == x  -> walk toks xs+                | otherwise -> eerr $ errExpect x+        +-- | The parser @try p@ behaves like parser @p@, except that it+-- pretends that it hasn't consumed any input when an error occurs.+--+-- This combinator is used whenever arbitrary look ahead is needed.+-- Since it pretends that it hasn't consumed any input when @p@ fails,+-- the ('<|>') combinator will try its second alternative even when the+-- first parser failed while consuming input.+--+-- The @try@ combinator can for example be used to distinguish+-- identifiers and reserved words. Both reserved words and identifiers+-- are a sequence of letters. Whenever we expect a certain reserved+-- word where we can also expect an identifier we have to use the @try@+-- combinator. Suppose we write:+--+-- >  expr        = letExpr <|> identifier <?> "expression"+-- >+-- >  letExpr     = do{ string "let"; ... }+-- >  identifier  = many1 letter+--+-- If the user writes \"lexical\", the parser fails with: @unexpected+-- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator+-- only tries alternatives when the first alternative hasn't consumed+-- input, the @identifier@ parser is never tried (because the prefix+-- \"le\" of the @string \"let\"@ parser is already consumed). The+-- right behaviour can be obtained by adding the @try@ combinator:+--+-- >  expr        = letExpr <|> identifier <?> "expression"+-- >+-- >  letExpr     = do{ try (string "let"); ... }+-- >  identifier  = many1 letter++try :: ParsecT s u m a -> ParsecT s u m a+try p =+    ParsecT $ \s cok _ eok eerr ->+    unParser p s cok eerr eok eerr++-- | @lookAhead p@ parses @p@ without consuming any input.+--+-- If @p@ fails and consumes some input, so does @lookAhead@. Combine with 'try'+-- if this is undesirable.++lookAhead :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a+lookAhead p         = do{ state <- getParserState+                        ; x <- p'+                        ; setParserState state+                        ; return x+                        }+    where+    p' = ParsecT $ \s cok cerr eok eerr ->+         unParser p s eok cerr eok eerr++-- | The parser @tokenPrim showTok posFromTok testTok@ accepts a token @t@+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The+-- source position of the @t@ should be returned by @posFromTok t@ and+-- the token can be shown using @showTok t@.+--+-- This combinator is expressed in terms of 'tokenPrim'.+-- It is used to accept user defined token streams. For example,+-- suppose that we have a stream of basic tokens tupled with source+-- positions. We can than define a parser that accepts single tokens as:+--+-- >  mytoken x+-- >    = token showTok posFromTok testTok+-- >    where+-- >      showTok (pos,t)     = show t+-- >      posFromTok (pos,t)  = pos+-- >      testTok (pos,t)     = if x == t then Just t else Nothing++token :: (Stream s Identity t)+      => (t -> String)            -- ^ Token pretty-printing function.+      -> (t -> SourcePos)         -- ^ Computes the position of a token.+      -> (t -> Maybe a)           -- ^ Matching function for the token to parse.+      -> Parsec s u a+token showToken tokpos test = tokenPrim showToken nextpos test+    where+        nextpos _ tok ts = case runIdentity (uncons ts) of+                             Nothing -> tokpos tok+                             Just (tok',_) -> tokpos tok'++-- | The parser @token showTok nextPos testTok@ accepts a token @t@+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The+-- token can be shown using @showTok t@. The position of the /next/+-- token should be returned when @nextPos@ is called with the current+-- source position @pos@, the current token @t@ and the rest of the+-- tokens @toks@, @nextPos pos t toks@.+--+-- This is the most primitive combinator for accepting tokens. For+-- example, the 'Text.Parsec.Char.char' parser could be implemented as:+--+-- >  char c+-- >    = tokenPrim showChar nextPos testChar+-- >    where+-- >      showChar x        = "'" ++ x ++ "'"+-- >      testChar x        = if x == c then Just x else Nothing+-- >      nextPos pos x xs  = updatePosChar pos x++tokenPrim :: (Stream s m t)+          => (t -> String)                      -- ^ Token pretty-printing function.+          -> (SourcePos -> t -> s -> SourcePos) -- ^ Next position calculating function.+          -> (t -> Maybe a)                     -- ^ Matching function for the token to parse.+          -> ParsecT s u m a+{-# INLINE tokenPrim #-}+tokenPrim showToken nextpos test = tokenPrimEx showToken nextpos Nothing test++tokenPrimEx :: (Stream s m t)+            => (t -> String)      +            -> (SourcePos -> t -> s -> SourcePos)+            -> Maybe (SourcePos -> t -> s -> u -> u)+            -> (t -> Maybe a)     +            -> ParsecT s u m a+{-# INLINE tokenPrimEx #-}+tokenPrimEx showToken nextpos Nothing test+  = ParsecT $ \(State input pos user) cok cerr eok eerr -> do+      r <- uncons input+      case r of+        Nothing -> eerr $ unexpectError "" pos+        Just (c,cs)+         -> case test c of+              Just x -> let newpos = nextpos pos c cs+                            newstate = State cs newpos user+                        in seq newpos $ seq newstate $+                           cok x newstate (newErrorUnknown newpos)+              Nothing -> eerr $ unexpectError (showToken c) pos+tokenPrimEx showToken nextpos (Just nextState) test+  = ParsecT $ \(State input pos user) cok cerr eok eerr -> do+      r <- uncons input+      case r of+        Nothing -> eerr $ unexpectError "" pos+        Just (c,cs)+         -> case test c of+              Just x -> let newpos = nextpos pos c cs+                            newUser = nextState pos c cs user+                            newstate = State cs newpos newUser+                        in seq newpos $ seq newstate $+                           cok x newstate $ newErrorUnknown newpos+              Nothing -> eerr $ unexpectError (showToken c) pos++unexpectError msg pos = newErrorMessage (SysUnExpect msg) pos+++-- | @many p@ applies the parser @p@ /zero/ or more times. Returns a+--    list of the returned values of @p@.+--+-- >  identifier  = do{ c  <- letter+-- >                  ; cs <- many (alphaNum <|> char '_')+-- >                  ; return (c:cs)+-- >                  }++many :: ParsecT s u m a -> ParsecT s u m [a]+many p+  = do xs <- manyAccum (:) p+       return (reverse xs)++-- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping+-- its result.+--+-- >  spaces  = skipMany space++skipMany :: ParsecT s u m a -> ParsecT s u m ()+skipMany p+  = do manyAccum (\_ _ -> []) p+       return ()++manyAccum :: (a -> [a] -> [a])+          -> ParsecT s u m a+          -> ParsecT s u m [a]+manyAccum acc p =+    ParsecT $ \s cok cerr eok eerr ->+    let walk xs x s' err =+            unParser p s'+              (seq xs $ walk $ acc x xs)  -- consumed-ok+              cerr                        -- consumed-err+              manyErr                     -- empty-ok+              (\e -> cok (acc x xs) s' e) -- empty-err+    in unParser p s (walk []) cerr manyErr (\e -> eok [] s e)++manyErr = error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."+++-- < Running a parser: monadic (runPT) and pure (runP)++runPT :: (Stream s m t)+      => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)+runPT p u name s+    = do res <- runParsecT p (State s (initialPos name) u)+         r <- parserReply res+         case r of+           Ok x _ _  -> return (Right x)+           Error err -> return (Left err)+    where+        parserReply res+            = case res of+                Consumed r -> r+                Empty    r -> r++runP :: (Stream s Identity t)+     => Parsec s u a -> u -> SourceName -> s -> Either ParseError a+runP p u name s = runIdentity $ runPT p u name s++-- | The most general way to run a parser. @runParserT p state filePath+-- input@ runs parser @p@ on the input list of tokens @input@,+-- obtained from source @filePath@ with the initial user state @st@.+-- The @filePath@ is only used in error messages and may be the empty+-- string. Returns a computation in the underlying monad @m@ that return either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right').++runParserT :: (Stream s m t)+           => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)+runParserT = runPT++-- | The most general way to run a parser over the Identity monad. @runParser p state filePath+-- input@ runs parser @p@ on the input list of tokens @input@,+-- obtained from source @filePath@ with the initial user state @st@.+-- The @filePath@ is only used in error messages and may be the empty+-- string. Returns either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right').+--+-- >  parseFromFile p fname+-- >    = do{ input <- readFile fname+-- >        ; return (runParser p () fname input)+-- >        }++runParser :: (Stream s Identity t)+          => Parsec s u a -> u -> SourceName -> s -> Either ParseError a+runParser = runP++-- | @parse p filePath input@ runs a parser @p@ over Identity without user+-- state. The @filePath@ is only used in error messages and may be the+-- empty string. Returns either a 'ParseError' ('Left')+-- or a value of type @a@ ('Right').+--+-- >  main    = case (parse numbers "" "11, 2, 43") of+-- >             Left err  -> print err+-- >             Right xs  -> print (sum xs)+-- >+-- >  numbers = commaSep integer++parse :: (Stream s Identity t)+      => Parsec s () a -> SourceName -> s -> Either ParseError a+parse p = runP p ()++-- | The expression @parseTest p input@ applies a parser @p@ against+-- input @input@ and prints the result to stdout. Used for testing+-- parsers.++parseTest :: (Stream s Identity t, Show a)+          => Parsec s () a -> s -> IO ()+parseTest p input+    = case parse p "" input of+        Left err -> do putStr "parse error at "+                       print err+        Right x  -> print x++-- < Parser state combinators++-- | Returns the current source position. See also 'SourcePos'.++getPosition :: (Monad m) => ParsecT s u m SourcePos+getPosition = do state <- getParserState+                 return (statePos state)++-- | Returns the current input ++getInput :: (Monad m) => ParsecT s u m s+getInput = do state <- getParserState+              return (stateInput state)++-- | @setPosition pos@ sets the current source position to @pos@. ++setPosition :: (Monad m) => SourcePos -> ParsecT s u m ()+setPosition pos+    = do updateParserState (\(State input _ user) -> State input pos user)+         return ()++-- | @setInput input@ continues parsing with @input@. The 'getInput' and+-- @setInput@ functions can for example be used to deal with #include+-- files. ++setInput :: (Monad m) => s -> ParsecT s u m ()+setInput input+    = do updateParserState (\(State _ pos user) -> State input pos user)+         return ()++-- | Returns the full parser state as a 'State' record.++getParserState :: (Monad m) => ParsecT s u m (State s u)+getParserState = updateParserState id++-- | @setParserState st@ set the full parser state to @st@. ++setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u)+setParserState st = updateParserState (const st)++-- | @updateParserState f@ applies function @f@ to the parser state.++updateParserState :: (State s u -> State s u) -> ParsecT s u m (State s u)+updateParserState f =+    ParsecT $ \s _ _ eok _ ->+    let s' = f s +    in eok s' s' $ unknownError s' ++-- < User state combinators++-- | Returns the current user state. ++getState :: (Monad m) => ParsecT s u m u+getState = stateUser `liftM` getParserState++-- | @putState st@ set the user state to @st@. ++putState :: (Monad m) => u -> ParsecT s u m ()+putState u = do updateParserState $ \s -> s { stateUser = u }+                return ()++-- | @updateState f@ applies function @f@ to the user state. Suppose+-- that we want to count identifiers in a source, we could use the user+-- state as:+--+-- >  expr  = do{ x <- identifier+-- >            ; updateState (+1)+-- >            ; return (Id x)+-- >            }++modifyState :: (Monad m) => (u -> u) -> ParsecT s u m ()+modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) }+                   return ()++-- XXX Compat++-- | An alias for putState for backwards compatibility.++setState :: (Monad m) => u -> ParsecT s u m ()+setState = putState++-- | An alias for modifyState for backwards compatibility.++updateState :: (Monad m) => (u -> u) -> ParsecT s u m ()+updateState = modifyState
+ Text/Parsec/String.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.String+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make Strings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.String+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++instance (Monad m) => Stream [tok] m tok where+    uncons []     = return $ Nothing+    uncons (t:ts) = return $ Just (t,ts)+    {-# INLINE uncons #-}++type Parser = Parsec String ()+type GenParser tok st = Parsec [tok] st++-- | @parseFromFile p filePath@ runs a string parser @p@ on the+-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }+parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- readFile fname+         return (runP p () fname input)
+ Text/Parsec/Text.hs view
@@ -0,0 +1,31 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.String+-- Copyright   :  (c) Antoine Latter 2011+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  aslatter@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make Text an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.Text+    ( Parser, GenParser+    ) where++import qualified Data.Text as Text+import Text.Parsec.Error+import Text.Parsec.Prim++instance (Monad m) => Stream Text.Text m Char where+    uncons = return . Text.uncons+    {-# INLINE uncons #-}++type Parser = Parsec Text.Text ()+type GenParser st = Parsec Text.Text st
+ Text/Parsec/Text/Lazy.hs view
@@ -0,0 +1,31 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.String+-- Copyright   :  (c) Antoine Latter 2011+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  aslatter@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make Text an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.Text.Lazy+    ( Parser, GenParser+    ) where++import qualified Data.Text.Lazy as Text+import Text.Parsec.Error+import Text.Parsec.Prim++instance (Monad m) => Stream Text.Text m Char where+    uncons = return . Text.uncons+    {-# INLINE uncons #-}++type Parser = Parsec Text.Text ()+type GenParser st = Parsec Text.Text st
+ Text/Parsec/Token.hs view
@@ -0,0 +1,722 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Token+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses local universal quantification: PolymorphicComponents)+-- +-- A helper module to parse lexical elements (tokens). See 'makeTokenParser'+-- for a description of how to use it.+-- +-----------------------------------------------------------------------------++{-# LANGUAGE PolymorphicComponents #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Text.Parsec.Token+    ( LanguageDef+    , GenLanguageDef (..)+    , TokenParser+    , GenTokenParser (..)+    , makeTokenParser+    ) where++import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt )+import Data.List ( nub, sort )+import Control.Monad.Identity+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator++-----------------------------------------------------------+-- Language Definition+-----------------------------------------------------------++type LanguageDef st = GenLanguageDef String st Identity++-- | The @GenLanguageDef@ type is a record that contains all parameterizable+-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language'+-- contains some default definitions.++data GenLanguageDef s u m+    = LanguageDef { +    +    -- | Describes the start of a block comment. Use the empty string if the+    -- language doesn't support block comments. For example \"\/*\". ++    commentStart   :: String,++    -- | Describes the end of a block comment. Use the empty string if the+    -- language doesn't support block comments. For example \"*\/\". ++    commentEnd     :: String,++    -- | Describes the start of a line comment. Use the empty string if the+    -- language doesn't support line comments. For example \"\/\/\". ++    commentLine    :: String,++    -- | Set to 'True' if the language supports nested block comments. ++    nestedComments :: Bool,++    -- | This parser should accept any start characters of identifiers. For+    -- example @letter \<|> char \"_\"@. ++    identStart     :: ParsecT s u m Char,++    -- | This parser should accept any legal tail characters of identifiers.+    -- For example @alphaNum \<|> char \"_\"@. ++    identLetter    :: ParsecT s u m Char,++    -- | This parser should accept any start characters of operators. For+    -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@ ++    opStart        :: ParsecT s u m Char,++    -- | This parser should accept any legal tail characters of operators.+    -- Note that this parser should even be defined if the language doesn't+    -- support user-defined operators, or otherwise the 'reservedOp'+    -- parser won't work correctly. ++    opLetter       :: ParsecT s u m Char,++    -- | The list of reserved identifiers. ++    reservedNames  :: [String],++    -- | The list of reserved operators. ++    reservedOpNames:: [String],++    -- | Set to 'True' if the language is case sensitive. ++    caseSensitive  :: Bool++    }++-----------------------------------------------------------+-- A first class module: TokenParser+-----------------------------------------------------------++type TokenParser st = GenTokenParser String st Identity++-- | The type of the record that holds lexical parsers that work on+-- @s@ streams with state @u@ over a monad @m@.++data GenTokenParser s u m+    = TokenParser {++        -- | This lexeme parser parses a legal identifier. Returns the identifier+        -- string. This parser will fail on identifiers that are reserved+        -- words. Legal identifier (start) characters and reserved words are+        -- defined in the 'LanguageDef' that is passed to+        -- 'makeTokenParser'. An @identifier@ is treated as+        -- a single token using 'try'.++        identifier       :: ParsecT s u m String,+        +        -- | The lexeme parser @reserved name@ parses @symbol +        -- name@, but it also checks that the @name@ is not a prefix of a+        -- valid identifier. A @reserved@ word is treated as a single token+        -- using 'try'. ++        reserved         :: String -> ParsecT s u m (),++        -- | This lexeme parser parses a legal operator. Returns the name of the+        -- operator. This parser will fail on any operators that are reserved+        -- operators. Legal operator (start) characters and reserved operators+        -- are defined in the 'LanguageDef' that is passed to+        -- 'makeTokenParser'. An @operator@ is treated as a+        -- single token using 'try'. ++        operator         :: ParsecT s u m String,++        -- |The lexeme parser @reservedOp name@ parses @symbol+        -- name@, but it also checks that the @name@ is not a prefix of a+        -- valid operator. A @reservedOp@ is treated as a single token using+        -- 'try'. ++        reservedOp       :: String -> ParsecT s u m (),+++        -- | This lexeme parser parses a single literal character. Returns the+        -- literal character value. This parsers deals correctly with escape+        -- sequences. The literal character is parsed according to the grammar+        -- rules defined in the Haskell report (which matches most programming+        -- languages quite closely). ++        charLiteral      :: ParsecT s u m Char,++        -- | This lexeme parser parses a literal string. Returns the literal+        -- string value. This parsers deals correctly with escape sequences and+        -- gaps. The literal string is parsed according to the grammar rules+        -- defined in the Haskell report (which matches most programming+        -- languages quite closely). ++        stringLiteral    :: ParsecT s u m String,++        -- | This lexeme parser parses a natural number (a positive whole+        -- number). Returns the value of the number. The number can be+        -- specified in 'decimal', 'hexadecimal' or+        -- 'octal'. The number is parsed according to the grammar+        -- rules in the Haskell report. ++        natural          :: ParsecT s u m Integer,++        -- | This lexeme parser parses an integer (a whole number). This parser+        -- is like 'natural' except that it can be prefixed with+        -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The+        -- number can be specified in 'decimal', 'hexadecimal'+        -- or 'octal'. The number is parsed according+        -- to the grammar rules in the Haskell report. +        +        integer          :: ParsecT s u m Integer,++        -- | This lexeme parser parses a floating point value. Returns the value+        -- of the number. The number is parsed according to the grammar rules+        -- defined in the Haskell report. ++        float            :: ParsecT s u m Double,++        -- | This lexeme parser parses either 'natural' or a 'float'.+        -- Returns the value of the number. This parsers deals with+        -- any overlap in the grammar rules for naturals and floats. The number+        -- is parsed according to the grammar rules defined in the Haskell report. ++        naturalOrFloat   :: ParsecT s u m (Either Integer Double),++        -- | Parses a positive whole number in the decimal system. Returns the+        -- value of the number. ++        decimal          :: ParsecT s u m Integer,++        -- | Parses a positive whole number in the hexadecimal system. The number+        -- should be prefixed with \"0x\" or \"0X\". Returns the value of the+        -- number. ++        hexadecimal      :: ParsecT s u m Integer,++        -- | Parses a positive whole number in the octal system. The number+        -- should be prefixed with \"0o\" or \"0O\". Returns the value of the+        -- number. ++        octal            :: ParsecT s u m Integer,++        -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips+        -- trailing white space. ++        symbol           :: String -> ParsecT s u m String,++        -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace'+        -- parser, returning the value of @p@. Every lexical+        -- token (lexeme) is defined using @lexeme@, this way every parse+        -- starts at a point without white space. Parsers that use @lexeme@ are+        -- called /lexeme/ parsers in this document.+        -- +        -- The only point where the 'whiteSpace' parser should be+        -- called explicitly is the start of the main parser in order to skip+        -- any leading white space.+        --+        -- >    mainParser  = do{ whiteSpace+        -- >                     ; ds <- many (lexeme digit)+        -- >                     ; eof+        -- >                     ; return (sum ds)+        -- >                     }++        lexeme           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Parses any white space. White space consists of /zero/ or more+        -- occurrences of a 'space', a line comment or a block (multi+        -- line) comment. Block comments may be nested. How comments are+        -- started and ended is defined in the 'LanguageDef'+        -- that is passed to 'makeTokenParser'. ++        whiteSpace       :: ParsecT s u m (),++        -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis,+        -- returning the value of @p@.++        parens           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and+        -- \'}\'), returning the value of @p@. ++        braces           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\'+        -- and \'>\'), returning the value of @p@. ++        angles           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\'+        -- and \']\'), returning the value of @p@. ++        brackets         :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | DEPRECATED: Use 'brackets'.++        squares          :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser |semi| parses the character \';\' and skips any+        -- trailing white space. Returns the string \";\". ++        semi             :: ParsecT s u m String,++        -- | Lexeme parser @comma@ parses the character \',\' and skips any+        -- trailing white space. Returns the string \",\". ++        comma            :: ParsecT s u m String,++        -- | Lexeme parser @colon@ parses the character \':\' and skips any+        -- trailing white space. Returns the string \":\". ++        colon            :: ParsecT s u m String,++        -- | Lexeme parser @dot@ parses the character \'.\' and skips any+        -- trailing white space. Returns the string \".\". ++        dot              :: ParsecT s u m String,++        -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@+        -- separated by 'semi'. Returns a list of values returned by+        -- @p@.++        semiSep          :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@+        -- separated by 'semi'. Returns a list of values returned by @p@. ++        semiSep1         :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of+        -- @p@ separated by 'comma'. Returns a list of values returned+        -- by @p@. ++        commaSep         :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of+        -- @p@ separated by 'comma'. Returns a list of values returned+        -- by @p@. ++        commaSep1        :: forall a . ParsecT s u m a -> ParsecT s u m [a]+    }++-----------------------------------------------------------+-- Given a LanguageDef, create a token parser.+-----------------------------------------------------------++-- | The expression @makeTokenParser language@ creates a 'GenTokenParser'+-- record that contains lexical parsers that are+-- defined using the definitions in the @language@ record.+--+-- The use of this function is quite stylized - one imports the+-- appropiate language definition and selects the lexical parsers that+-- are needed from the resulting 'GenTokenParser'.+--+-- >  module Main where+-- >+-- >  import Text.Parsec+-- >  import qualified Text.Parsec.Token as P+-- >  import Text.Parsec.Language (haskellDef)+-- >+-- >  -- The parser+-- >  ...+-- >+-- >  expr  =   parens expr+-- >        <|> identifier+-- >        <|> ...+-- >       +-- >+-- >  -- The lexer+-- >  lexer       = P.makeTokenParser haskellDef    +-- >      +-- >  parens      = P.parens lexer+-- >  braces      = P.braces lexer+-- >  identifier  = P.identifier lexer+-- >  reserved    = P.reserved lexer+-- >  ...++makeTokenParser :: (Stream s m Char)+                => GenLanguageDef s u m -> GenTokenParser s u m+makeTokenParser languageDef+    = TokenParser{ identifier = identifier+                 , reserved = reserved+                 , operator = operator+                 , reservedOp = reservedOp++                 , charLiteral = charLiteral+                 , stringLiteral = stringLiteral+                 , natural = natural+                 , integer = integer+                 , float = float+                 , naturalOrFloat = naturalOrFloat+                 , decimal = decimal+                 , hexadecimal = hexadecimal+                 , octal = octal++                 , symbol = symbol+                 , lexeme = lexeme+                 , whiteSpace = whiteSpace++                 , parens = parens+                 , braces = braces+                 , angles = angles+                 , brackets = brackets+                 , squares = brackets+                 , semi = semi+                 , comma = comma+                 , colon = colon+                 , dot = dot+                 , semiSep = semiSep+                 , semiSep1 = semiSep1+                 , commaSep = commaSep+                 , commaSep1 = commaSep1+                 }+    where++    -----------------------------------------------------------+    -- Bracketing+    -----------------------------------------------------------+    parens p        = between (symbol "(") (symbol ")") p+    braces p        = between (symbol "{") (symbol "}") p+    angles p        = between (symbol "<") (symbol ">") p+    brackets p      = between (symbol "[") (symbol "]") p++    semi            = symbol ";"+    comma           = symbol ","+    dot             = symbol "."+    colon           = symbol ":"++    commaSep p      = sepBy p comma+    semiSep p       = sepBy p semi++    commaSep1 p     = sepBy1 p comma+    semiSep1 p      = sepBy1 p semi+++    -----------------------------------------------------------+    -- Chars & Strings+    -----------------------------------------------------------+    charLiteral     = lexeme (between (char '\'')+                                      (char '\'' <?> "end of character")+                                      characterChar )+                    <?> "character"++    characterChar   = charLetter <|> charEscape+                    <?> "literal character"++    charEscape      = do{ char '\\'; escapeCode }+    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++++    stringLiteral   = lexeme (+                      do{ str <- between (char '"')+                                         (char '"' <?> "end of string")+                                         (many stringChar)+                        ; return (foldr (maybe id (:)) "" str)+                        }+                      <?> "literal string")++    stringChar      =   do{ c <- stringLetter; return (Just c) }+                    <|> stringEscape+                    <?> "string character"++    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++    stringEscape    = do{ char '\\'+                        ;     do{ escapeGap  ; return Nothing }+                          <|> do{ escapeEmpty; return Nothing }+                          <|> do{ esc <- escapeCode; return (Just esc) }+                        }++    escapeEmpty     = char '&'+    escapeGap       = do{ many1 space+                        ; char '\\' <?> "end of string gap"+                        }++++    -- escape codes+    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl+                    <?> "escape code"++    charControl     = do{ char '^'+                        ; code <- upper+                        ; return (toEnum (fromEnum code - fromEnum 'A'))+                        }++    charNum         = do{ code <- decimal+                                  <|> do{ char 'o'; number 8 octDigit }+                                  <|> do{ char 'x'; number 16 hexDigit }+                        ; return (toEnum (fromInteger code))+                        }++    charEsc         = choice (map parseEsc escMap)+                    where+                      parseEsc (c,code)     = do{ char c; return code }++    charAscii       = choice (map parseAscii asciiMap)+                    where+                      parseAscii (asc,code) = try (do{ string asc; return code })+++    -- escape code tables+    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++    ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+                       "FS","GS","RS","US","SP"]+    ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+                       "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+                       "CAN","SUB","ESC","DEL"]++    ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+                       '\EM','\FS','\GS','\RS','\US','\SP']+    ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+                       '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+                       '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']+++    -----------------------------------------------------------+    -- Numbers+    -----------------------------------------------------------+    naturalOrFloat  = lexeme (natFloat) <?> "number"++    float           = lexeme floating   <?> "float"+    integer         = lexeme int        <?> "integer"+    natural         = lexeme nat        <?> "natural"+++    -- floats+    floating        = do{ n <- decimal+                        ; fractExponent n+                        }+++    natFloat        = do{ char '0'+                        ; zeroNumFloat+                        }+                      <|> decimalFloat++    zeroNumFloat    =  do{ n <- hexadecimal <|> octal+                         ; return (Left n)+                         }+                    <|> decimalFloat+                    <|> fractFloat 0+                    <|> return (Left 0)++    decimalFloat    = do{ n <- decimal+                        ; option (Left n)+                                 (fractFloat n)+                        }++    fractFloat n    = do{ f <- fractExponent n+                        ; return (Right f)+                        }++    fractExponent n = do{ fract <- fraction+                        ; expo  <- option 1.0 exponent'+                        ; return ((fromInteger n + fract)*expo)+                        }+                    <|>+                      do{ expo <- exponent'+                        ; return ((fromInteger n)*expo)+                        }++    fraction        = do{ char '.'+                        ; digits <- many1 digit <?> "fraction"+                        ; return (foldr op 0.0 digits)+                        }+                      <?> "fraction"+                    where+                      op d f    = (f + fromIntegral (digitToInt d))/10.0++    exponent'       = do{ oneOf "eE"+                        ; f <- sign+                        ; e <- decimal <?> "exponent"+                        ; return (power (f e))+                        }+                      <?> "exponent"+                    where+                       power e  | e < 0      = 1.0/power(-e)+                                | otherwise  = fromInteger (10^e)+++    -- integers and naturals+    int             = do{ f <- lexeme sign+                        ; n <- nat+                        ; return (f n)+                        }++    sign            =   (char '-' >> return negate)+                    <|> (char '+' >> return id)+                    <|> return id++    nat             = zeroNumber <|> decimal++    zeroNumber      = do{ char '0'+                        ; hexadecimal <|> octal <|> decimal <|> return 0+                        }+                      <?> ""++    decimal         = number 10 digit+    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }+    octal           = do{ oneOf "oO"; number 8 octDigit  }++    number base baseDigit+        = do{ digits <- many1 baseDigit+            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+            ; seq n (return n)+            }++    -----------------------------------------------------------+    -- Operators & reserved ops+    -----------------------------------------------------------+    reservedOp name =+        lexeme $ try $+        do{ string name+          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+          }++    operator =+        lexeme $ try $+        do{ name <- oper+          ; if (isReservedOp name)+             then unexpected ("reserved operator " ++ show name)+             else return name+          }++    oper =+        do{ c <- (opStart languageDef)+          ; cs <- many (opLetter languageDef)+          ; return (c:cs)+          }+        <?> "operator"++    isReservedOp name =+        isReserved (sort (reservedOpNames languageDef)) name+++    -----------------------------------------------------------+    -- Identifiers & Reserved words+    -----------------------------------------------------------+    reserved name =+        lexeme $ try $+        do{ caseString name+          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+          }++    caseString name+        | caseSensitive languageDef  = string name+        | otherwise               = do{ walk name; return name }+        where+          walk []     = return ()+          walk (c:cs) = do{ caseChar c <?> msg; walk cs }++          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)+                      | otherwise  = char c++          msg         = show name+++    identifier =+        lexeme $ try $+        do{ name <- ident+          ; if (isReservedName name)+             then unexpected ("reserved word " ++ show name)+             else return name+          }+++    ident+        = do{ c <- identStart languageDef+            ; cs <- many (identLetter languageDef)+            ; return (c:cs)+            }+        <?> "identifier"++    isReservedName name+        = isReserved theReservedNames caseName+        where+          caseName      | caseSensitive languageDef  = name+                        | otherwise               = map toLower name+++    isReserved names name+        = scan names+        where+          scan []       = False+          scan (r:rs)   = case (compare r name) of+                            LT  -> scan rs+                            EQ  -> True+                            GT  -> False++    theReservedNames+        | caseSensitive languageDef  = sort reserved+        | otherwise                  = sort . map (map toLower) $ reserved+        where+          reserved = reservedNames languageDef++++    -----------------------------------------------------------+    -- White space & symbols+    -----------------------------------------------------------+    symbol name+        = lexeme (string name)++    lexeme p+        = do{ x <- p; whiteSpace; return x  }+++    --whiteSpace+    whiteSpace+        | noLine && noMulti  = skipMany (simpleSpace <?> "")+        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")+        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")+        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+        where+          noLine  = null (commentLine languageDef)+          noMulti = null (commentStart languageDef)+++    simpleSpace =+        skipMany1 (satisfy isSpace)++    oneLineComment =+        do{ try (string (commentLine languageDef))+          ; skipMany (satisfy (/= '\n'))+          ; return ()+          }++    multiLineComment =+        do { try (string (commentStart languageDef))+           ; inComment+           }++    inComment+        | nestedComments languageDef  = inCommentMulti+        | otherwise                = inCommentSingle++    inCommentMulti+        =   do{ try (string (commentEnd languageDef)) ; return () }+        <|> do{ multiLineComment                     ; inCommentMulti }+        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }+        <|> do{ oneOf startEnd                       ; inCommentMulti }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)++    inCommentSingle+        =   do{ try (string (commentEnd languageDef)); return () }+        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }+        <|> do{ oneOf startEnd                      ; inCommentSingle }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
+ Text/ParserCombinators/Parsec.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec+    ( -- complete modules+      module Text.ParserCombinators.Parsec.Prim+    , module Text.ParserCombinators.Parsec.Combinator+    , module Text.ParserCombinators.Parsec.Char++    -- module Text.ParserCombinators.Parsec.Error+    , ParseError+    , errorPos++    -- module Text.ParserCombinators.Parsec.Pos+    , SourcePos+    , SourceName, Line, Column+    , sourceName, sourceLine, sourceColumn+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName++    ) where++import Text.Parsec.String()++import Text.ParserCombinators.Parsec.Prim+import Text.ParserCombinators.Parsec.Combinator+import Text.ParserCombinators.Parsec.Char++import Text.ParserCombinators.Parsec.Error+import Text.ParserCombinators.Parsec.Pos
+ Text/ParserCombinators/Parsec/Char.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Char+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Char+    ( CharParser,+      spaces,+      space,+      newline,+      tab,+      upper,+      lower,+      alphaNum,+      letter,+      digit,+      hexDigit,+      octDigit,+      char,+      string,+      anyChar,+      oneOf,+      noneOf,+      satisfy+    ) where+++import Text.Parsec.Char+import Text.Parsec.String++type CharParser st = GenParser Char st
+ Text/ParserCombinators/Parsec/Combinator.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Combinator+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Combinator+    ( choice,+      count,+      between,+      option,+      optionMaybe,+      optional,+      skipMany1,+      many1,+      sepBy,+      sepBy1,+      endBy,+      endBy1,+      sepEndBy,+      sepEndBy1,+      chainl,+      chainl1,+      chainr,+      chainr1,+      eof,+      notFollowedBy,+      manyTill,+      lookAhead,+      anyToken+    ) where+++import Text.Parsec.Combinator
+ Text/ParserCombinators/Parsec/Error.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Error+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Error+    ( Message (SysUnExpect,UnExpect,Expect,Message),+      messageString,+      messageCompare,+      messageEq,+      ParseError,+      errorPos,+      errorMessages,+      errorIsUnknown,+      showErrorMessages,+      newErrorMessage,+      newErrorUnknown,+      addErrorMessage,+      setErrorPos,+      setErrorMessage,+      mergeError+    ) where++import Text.Parsec.Error+++messageCompare :: Message -> Message -> Ordering+messageCompare = compare++messageEq :: Message -> Message -> Bool+messageEq = (==)
+ Text/ParserCombinators/Parsec/Expr.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Expr+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Expr+    ( Assoc (AssocNone,AssocLeft,AssocRight),+      Operator(..),+      OperatorTable,+      buildExpressionParser+    ) where++import Text.Parsec.Expr(Assoc(..))+import qualified Text.Parsec.Expr as N+import Text.ParserCombinators.Parsec(GenParser)++import Control.Monad.Identity++data Operator tok st a   = Infix  (GenParser tok st (a -> a -> a)) Assoc+                         | Prefix (GenParser tok st (a -> a))+                         | Postfix (GenParser tok st (a -> a))++type OperatorTable tok st a = [[Operator tok st a]]++convert :: Operator tok st a -> N.Operator [tok] st Identity a+convert (Infix p a) = N.Infix p a+convert (Prefix p)  = N.Prefix p+convert (Postfix p)  = N.Postfix p++buildExpressionParser :: OperatorTable tok st a+                      -> GenParser tok st a+                      -> GenParser tok st a+buildExpressionParser = N.buildExpressionParser . map (map convert)
+ Text/ParserCombinators/Parsec/Language.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Language+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Language+    ( haskellDef,+      haskell,+      mondrianDef,+      mondrian,+      emptyDef,+      haskellStyle,+      javaStyle,+      LanguageDef,+      GenLanguageDef(..),+    ) where++import Text.Parsec.Token+import Text.Parsec.Language
+ Text/ParserCombinators/Parsec/Perm.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Perm+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Perm+    ( PermParser,+      permute,+      (<||>),+      (<$$>),+      (<|?>),+      (<$?>)+    ) where++import Text.Parsec.Perm
+ Text/ParserCombinators/Parsec/Pos.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Pos+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Pos+    ( SourceName,+      Line,+      Column,+      SourcePos,+      sourceLine,+      sourceColumn,+      sourceName,+      incSourceLine,+      incSourceColumn,+      setSourceLine,+      setSourceColumn,+      setSourceName,+      newPos,+      initialPos,+      updatePosChar,+      updatePosString+    ) where+      ++import Text.Parsec.Pos
+ Text/ParserCombinators/Parsec/Prim.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Prim+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Prim+    ( (<?>),+      (<|>),+      Parser,+      GenParser,+      runParser,+      parse,+      parseFromFile,+      parseTest,+      token,+      tokens,+      tokenPrim,+      tokenPrimEx,+      try,+      label,+      labels,+      unexpected,+      pzero,+      many,+      skipMany,+      getState,+      setState,+      updateState,+      getPosition,+      setPosition,+      getInput,+      setInput,+      State(..),+      getParserState,+      setParserState+    ) where++import Text.Parsec.Prim hiding (runParser, try)+import qualified Text.Parsec.Prim as N -- 'N' for 'New'+import Text.Parsec.String++import Text.Parsec.Error+import Text.Parsec.Pos++pzero :: GenParser tok st a+pzero = parserZero++runParser :: GenParser tok st a+          -> st+          -> SourceName+          -> [tok]+          -> Either ParseError a+runParser = N.runParser++try :: GenParser tok st a -> GenParser tok st a+try = N.try
+ Text/ParserCombinators/Parsec/Token.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.ParserCombinators.Parsec.Token+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parsec compatibility module+-- +-----------------------------------------------------------------------------++module Text.ParserCombinators.Parsec.Token+    ( LanguageDef,+      GenLanguageDef(..),+      TokenParser,+      GenTokenParser(..),+      makeTokenParser+    ) where++import Text.Parsec.Token
+ cabal-install-bundle.cabal view
@@ -0,0 +1,205 @@+Name:               cabal-install-bundle+Version:            0.10.2+Synopsis:           The (bundled) command-line interface for Cabal and Hackage.+Description:        This is cabal-install with bundled dependencies. Easier to bootstrap.+License:            BSD3+Maintainer:         paczesiowa@gmail.com+Category:           Distribution+build-type:         Configure+Cabal-Version:      >= 1.8+extra-tmp-files:+  config.log config.status autom4te.cache network.buildinfo+  include/HsNetworkConfig.h+extra-source-files:+  config.guess config.sub install-sh+  configure.ac configure network.buildinfo.in+  include/HsNetworkConfig.h.in include/HsNet.h+  -- C sources only used on some systems+  cbits/ancilData.c cbits/asyncAccept.c cbits/initWinSock.c+  cbits/winSockErr.c+  cbits/crc32.h cbits/inffast.h cbits/inflate.h+  cbits/trees.h cbits/deflate.h cbits/inffixed.h+  cbits/inftrees.h cbits/zutil.h++Executable cabal+    Main-Is:            Main.hs+    ghc-options:        -Wall+    include-dirs: include+    includes: HsNet.h zlib.h+    install-includes: HsNet.h HsNetworkConfig.h+    extra-libraries: z+    c-sources: cbits/HsNet.c+    Other-Modules:+        System.Random+        Codec.Compression.GZip,+        Codec.Compression.Zlib,+        Codec.Compression.Zlib.Raw,+        Codec.Compression.Zlib.Internal+        Codec.Compression.Zlib.Stream+        Control.Monad.Cont+        Control.Monad.Cont.Class+        Control.Monad.Error+        Control.Monad.Error.Class+        Control.Monad.Identity+        Control.Monad.List+        Control.Monad.RWS+        Control.Monad.RWS.Class+        Control.Monad.RWS.Lazy+        Control.Monad.RWS.Strict+        Control.Monad.Reader+        Control.Monad.Reader.Class+        Control.Monad.State+        Control.Monad.State.Class+        Control.Monad.State.Lazy+        Control.Monad.State.Strict+        Control.Monad.Trans+        Control.Monad.Writer+        Control.Monad.Writer.Class+        Control.Monad.Writer.Lazy+        Control.Monad.Writer.Strict+        Control.Applicative.Backwards+        Control.Applicative.Lift+        Control.Monad.IO.Class+        Control.Monad.Trans.Class+        Control.Monad.Trans.Cont+        Control.Monad.Trans.Error+        Control.Monad.Trans.Identity+        Control.Monad.Trans.List+        Control.Monad.Trans.Maybe+        Control.Monad.Trans.Reader+        Control.Monad.Trans.RWS+        Control.Monad.Trans.RWS.Lazy+        Control.Monad.Trans.RWS.Strict+        Control.Monad.Trans.State+        Control.Monad.Trans.State.Lazy+        Control.Monad.Trans.State.Strict+        Control.Monad.Trans.Writer+        Control.Monad.Trans.Writer.Lazy+        Control.Monad.Trans.Writer.Strict+        Data.Functor.Compose+        Data.Functor.Constant+        Data.Functor.Identity+        Data.Functor.Product+        Data.Functor.Reverse+        Text.Parsec,+        Text.Parsec.String,+        Text.Parsec.ByteString,+        Text.Parsec.ByteString.Lazy,+        Text.Parsec.Text,+        Text.Parsec.Text.Lazy,+        Text.Parsec.Pos,+        Text.Parsec.Error,+        Text.Parsec.Prim,+        Text.Parsec.Char,+        Text.Parsec.Combinator,+        Text.Parsec.Token,+        Text.Parsec.Expr,+        Text.Parsec.Language,+        Text.Parsec.Perm,+        Text.ParserCombinators.Parsec,+        Text.ParserCombinators.Parsec.Char,+        Text.ParserCombinators.Parsec.Combinator,+        Text.ParserCombinators.Parsec.Error,+        Text.ParserCombinators.Parsec.Expr,+        Text.ParserCombinators.Parsec.Language,+        Text.ParserCombinators.Parsec.Perm,+        Text.ParserCombinators.Parsec.Pos,+        Text.ParserCombinators.Parsec.Prim,+        Text.ParserCombinators.Parsec.Token+        Network+        Network.BSD+        Network.Socket+        Network.Socket.ByteString+        Network.Socket.ByteString.Lazy+        Network.Socket.Internal+        Network.URI+        Network.Socket.ByteString.Internal+        Network.Socket.ByteString.IOVec+        Network.Socket.ByteString.MsgHdr+        Network.BufferType,+        Network.Stream,+        Network.StreamDebugger,+        Network.StreamSocket,+        Network.TCP,+        Network.HTTP,+        Network.HTTP.Headers,+        Network.HTTP.Base,+        Network.HTTP.Stream,+        Network.HTTP.Auth,+        Network.HTTP.Cookie,+        Network.HTTP.Proxy,+        Network.HTTP.HandleStream,+        Network.Browser+        Network.HTTP.Base64,+        Network.HTTP.MD5Aux,+        Network.HTTP.Utils+        Distribution.Client.BuildReports.Anonymous+        Distribution.Client.BuildReports.Storage+        Distribution.Client.BuildReports.Types+        Distribution.Client.BuildReports.Upload+        Distribution.Client.Check+        Distribution.Client.Config+        Distribution.Client.Configure+        Distribution.Client.Dependency+        Distribution.Client.Dependency.TopDown+        Distribution.Client.Dependency.TopDown.Constraints+        Distribution.Client.Dependency.TopDown.Types+        Distribution.Client.Dependency.Types+        Distribution.Client.Dependency.Modular+        Distribution.Client.Dependency.Modular.Assignment+        Distribution.Client.Dependency.Modular.Builder+        Distribution.Client.Dependency.Modular.Configured+        Distribution.Client.Dependency.Modular.ConfiguredConversion+        Distribution.Client.Dependency.Modular.Dependency+        Distribution.Client.Dependency.Modular.Explore+        Distribution.Client.Dependency.Modular.Flag+        Distribution.Client.Dependency.Modular.Index+        Distribution.Client.Dependency.Modular.IndexConversion+        Distribution.Client.Dependency.Modular.Log+        Distribution.Client.Dependency.Modular.Message+        Distribution.Client.Dependency.Modular.Package+        Distribution.Client.Dependency.Modular.Preference+        Distribution.Client.Dependency.Modular.PSQ+        Distribution.Client.Dependency.Modular.Solver+        Distribution.Client.Dependency.Modular.Tree+        Distribution.Client.Dependency.Modular.Validate+        Distribution.Client.Dependency.Modular.Version+        Distribution.Client.Fetch+        Distribution.Client.FetchUtils+        Distribution.Client.GZipUtils+        Distribution.Client.Haddock+        Distribution.Client.HttpUtils+        Distribution.Client.IndexUtils+        Distribution.Client.Init+        Distribution.Client.Init.Heuristics+        Distribution.Client.Init.Licenses+        Distribution.Client.Init.Types+        Distribution.Client.Install+        Distribution.Client.InstallPlan+        Distribution.Client.InstallSymlink+        Distribution.Client.List+        Distribution.Client.PackageIndex+        Distribution.Client.PackageUtils+        Distribution.Client.Setup+        Distribution.Client.SetupWrapper+        Distribution.Client.SrcDist+        Distribution.Client.Tar+        Distribution.Client.Targets+        Distribution.Client.Types+        Distribution.Client.Unpack+        Distribution.Client.Update+        Distribution.Client.Upload+        Distribution.Client.Utils+        Distribution.Client.World+        Distribution.Client.Win32SelfUpgrade+        Distribution.Compat.Exception+        Distribution.Compat.FilePerms+        Paths_cabal_install_bundle++    build-depends: base >= 2 && < 99, Cabal >= 1.10, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix++    extensions: CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances, ExistentialQuantification, PolymorphicComponents, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, FunctionalDependencies++source-repository head+   type:     git+   location: git://github.com/Paczesiowa/cabal-install-bundle.git
+ cbits/HsNet.c view
@@ -0,0 +1,8 @@+/* -----------------------------------------------------------------------------+ * (c) The University of Glasgow 2002+ *+ * static versions of the inline functions from HsNet.h+ * -------------------------------------------------------------------------- */++#define INLINE+#include "HsNet.h"
+ cbits/ancilData.c view
@@ -0,0 +1,237 @@+/*+ *  Copyright(c), 2002 The GHC Team.+ */++#ifdef aix_HOST_OS+#define _LINUX_SOURCE_COMPAT +// Required to get CMSG_SPACE/CMSG_LEN macros.  See #265.+// Alternative is to #define COMPAT_43 and use the +// HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS code instead, but that means+// fiddling with the configure script too.+#endif++#include "HsNet.h"+#include <string.h>++#if HAVE_STRUCT_MSGHDR_MSG_CONTROL || HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS /* until end */++/* + *  Support for transmitting file descriptors.+ *+ *  + */+ ++/*+ * sendmsg() and recvmsg() wrappers for transmitting+ * ancillary socket data.+ *+ * Doesn't provide the full generality of either, specifically:+ *+ *  - no support for scattered read/writes.+ *  - only possible to send one ancillary chunk of data at a time.+ *+ *+ * NOTE: recv/sendAncillary() is being phased out in preference+ *       of the more specific send/recvFd(), as the latter is+ *       really the only application of recv/sendAncillary() and+ *       stand the chance of being supported on platforms that+ *       don't have send/recvmsg() (but do have ioctl() support+ *       for this kind of thing, for instance.)+ *+ */++int+sendFd(int sock,+       int outfd)+{+  struct msghdr msg = {0};+  struct iovec iov[1];+  char  buf[2];+#if HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS+  msg.msg_accrights = (void*)&outfd;+  msg.msg_accrightslen = sizeof(int);+#else+  struct cmsghdr *cmsg;+  char ancBuffer[CMSG_SPACE(sizeof(int))];+  char* dPtr;+  +  msg.msg_control = ancBuffer;+  msg.msg_controllen = sizeof(ancBuffer);++  cmsg = CMSG_FIRSTHDR(&msg);+  cmsg->cmsg_level = SOL_SOCKET;+  cmsg->cmsg_type = SCM_RIGHTS;+  cmsg->cmsg_len = CMSG_LEN(sizeof(int));+  dPtr = (char*)CMSG_DATA(cmsg);+  +  *(int*)dPtr = outfd;+  msg.msg_controllen = cmsg->cmsg_len;+#endif++  buf[0] = 0; buf[1] = '\0';+  iov[0].iov_base = buf;+  iov[0].iov_len  = 2;++  msg.msg_iov = iov;+  msg.msg_iovlen = 1;+  +  return sendmsg(sock,&msg,0);+}++int+sendAncillary(int sock,+	      int level,+	      int type,+	      int flags,+	      void* data,+	      int len)+{+  struct msghdr msg = {0};+  struct iovec iov[1];+  char  buf[2];+#if HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS+  /* Contains the older BSD msghdr fields only, so no room+     for 'type' or 'level' data.+  */+  msg.msg_accrights = data;+  msg.msg_accrightslen=len;+#else+  struct cmsghdr *cmsg;+  char ancBuffer[CMSG_SPACE(len)];+  char* dPtr;+  +  msg.msg_control = ancBuffer;+  msg.msg_controllen = sizeof(ancBuffer);++  cmsg = CMSG_FIRSTHDR(&msg);+  cmsg->cmsg_level = level;+  cmsg->cmsg_type = type;+  cmsg->cmsg_len = CMSG_LEN(len);+  dPtr = (char*)CMSG_DATA(cmsg);+  +  memcpy(dPtr, data, len);+  msg.msg_controllen = cmsg->cmsg_len;+#endif+  buf[0] = 0; buf[1] = '\0';+  iov[0].iov_base = buf;+  iov[0].iov_len  = 2;++  msg.msg_iov = iov;+  msg.msg_iovlen = 1;+  +  return sendmsg(sock,&msg,flags);+}++int+recvFd(int sock)+{+  struct msghdr msg = {0};+  char  duffBuf[10];+  int rc;+  int len = sizeof(int);+  struct iovec iov[1];+#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  struct cmsghdr *cmsg = NULL;+  struct cmsghdr *cptr;+#else+  int* fdBuffer;+#endif++  iov[0].iov_base = duffBuf;+  iov[0].iov_len  = sizeof(duffBuf);+  msg.msg_iov = iov;+  msg.msg_iovlen = 1;++#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  cmsg = (struct cmsghdr*)malloc(CMSG_SPACE(len));+  if (cmsg==NULL) {+    return -1;+  }+  +  msg.msg_control = (void *)cmsg;+  msg.msg_controllen = CMSG_LEN(len);+#else+  fdBuffer = (int*)malloc(len);+  if (fdBuffer) {+    msg.msg_accrights    = (void *)fdBuffer;+  } else {+    return -1;+  }+  msg.msg_accrightslen = len;+#endif++  if ((rc = recvmsg(sock,&msg,0)) < 0) {+    return rc;+  }+  +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg);+  return *(int*)CMSG_DATA(cptr);+#else+  return *(int*)fdBuffer;+#endif+}+++int+recvAncillary(int  sock,+	      int* pLevel,+	      int* pType,+	      int  flags,+	      void** pData,+	      int* pLen)+{+  struct msghdr msg = {0};+  char  duffBuf[10];+  int rc;+  struct iovec iov[1];+#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  struct cmsghdr *cmsg = NULL;+  struct cmsghdr *cptr;+#endif+  +  iov[0].iov_base = duffBuf;+  iov[0].iov_len  = sizeof(duffBuf);+  msg.msg_iov = iov;+  msg.msg_iovlen = 1;++#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  cmsg = (struct cmsghdr*)malloc(CMSG_SPACE(*pLen));+  if (cmsg==NULL) {+    return -1;+  }+  +  msg.msg_control = (void *)cmsg;+  msg.msg_controllen = CMSG_LEN(*pLen);+#else+  *pData = (void*)malloc(*pLen);+  if (*pData) {+      msg.msg_accrights    = *pData;+  } else {+      return -1;+  }+  msg.msg_accrightslen = *pLen;+#endif++  if ((rc = recvmsg(sock,&msg,flags)) < 0) {+    return rc;+  }+  +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL+  cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg);++  *pLevel = cptr->cmsg_level;+  *pType  = cptr->cmsg_type;+  /* The length of the data portion only */+  *pLen   = cptr->cmsg_len - sizeof(struct cmsghdr);+  *pData  = CMSG_DATA(cptr);+#else+  /* Sensible defaults, I hope.. */+  *pLevel = 0;+  *pType  = 0;+#endif++  return rc;+}+#endif
+ cbits/asyncAccept.c view
@@ -0,0 +1,72 @@+/*+ * (c) sof, 2003.+ */++#include "HsNet.h"+#include "HsFFI.h"++#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) && !defined(__HUGS__)++/* all the way to the end */++/*+ * To support non-blocking accept()s with WinSock, we use the asyncDoProc#+ * primop, which lets a Haskell thread call an external routine without+ * blocking the progress of other threads. + *+ * As can readily be seen, this is a low-level mechanism.+ *+ */++typedef struct AcceptData {+    int   fdSock;+    int   newSock;+    void* sockAddr;+    int   size;+} AcceptData;++/*+ * Fill in parameter block that's passed along when the RTS invokes the + * accept()-calling proc below (acceptDoProc())+ */+void*+newAcceptParams(int sock,+		int sz,+		void* sockaddr)+{+    AcceptData* data = (AcceptData*)malloc(sizeof(AcceptData));+    if (!data) return NULL;+    data->fdSock   = sock;+    data->newSock  = 0;+    data->sockAddr = sockaddr;+    data->size     = sz;+    +    return data;+}++/* Accessors for return code and accept()'s socket result. */++int+acceptNewSock(void* d)+{+    return (((AcceptData*)d)->newSock);+}++/* Routine invoked by an RTS worker thread */+int+acceptDoProc(void* param)+{+    SOCKET s;++    AcceptData* data = (AcceptData*)param;+    s = accept( data->fdSock,+		data->sockAddr,+		&data->size);+    data->newSock = s;+    if ( s == INVALID_SOCKET ) {+	return GetLastError();+    } else {+	return 0;+    }+}+#endif
+ cbits/crc32.h view
@@ -0,0 +1,441 @@+/* crc32.h -- tables for rapid CRC calculation+ * Generated automatically by crc32.c+ */++local const unsigned long FAR crc_table[TBLS][256] =+{+  {+    0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL,+    0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL,+    0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL,+    0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL,+    0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL,+    0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL,+    0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL,+    0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL,+    0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL,+    0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL,+    0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL,+    0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL,+    0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL,+    0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL,+    0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL,+    0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL,+    0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL,+    0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL,+    0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL,+    0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL,+    0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL,+    0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL,+    0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL,+    0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL,+    0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL,+    0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL,+    0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL,+    0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL,+    0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL,+    0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL,+    0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL,+    0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL,+    0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL,+    0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL,+    0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL,+    0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL,+    0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL,+    0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL,+    0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL,+    0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL,+    0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL,+    0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL,+    0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL,+    0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL,+    0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL,+    0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL,+    0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL,+    0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL,+    0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL,+    0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL,+    0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL,+    0x2d02ef8dUL+#ifdef BYFOUR+  },+  {+    0x00000000UL, 0x191b3141UL, 0x32366282UL, 0x2b2d53c3UL, 0x646cc504UL,+    0x7d77f445UL, 0x565aa786UL, 0x4f4196c7UL, 0xc8d98a08UL, 0xd1c2bb49UL,+    0xfaefe88aUL, 0xe3f4d9cbUL, 0xacb54f0cUL, 0xb5ae7e4dUL, 0x9e832d8eUL,+    0x87981ccfUL, 0x4ac21251UL, 0x53d92310UL, 0x78f470d3UL, 0x61ef4192UL,+    0x2eaed755UL, 0x37b5e614UL, 0x1c98b5d7UL, 0x05838496UL, 0x821b9859UL,+    0x9b00a918UL, 0xb02dfadbUL, 0xa936cb9aUL, 0xe6775d5dUL, 0xff6c6c1cUL,+    0xd4413fdfUL, 0xcd5a0e9eUL, 0x958424a2UL, 0x8c9f15e3UL, 0xa7b24620UL,+    0xbea97761UL, 0xf1e8e1a6UL, 0xe8f3d0e7UL, 0xc3de8324UL, 0xdac5b265UL,+    0x5d5daeaaUL, 0x44469febUL, 0x6f6bcc28UL, 0x7670fd69UL, 0x39316baeUL,+    0x202a5aefUL, 0x0b07092cUL, 0x121c386dUL, 0xdf4636f3UL, 0xc65d07b2UL,+    0xed705471UL, 0xf46b6530UL, 0xbb2af3f7UL, 0xa231c2b6UL, 0x891c9175UL,+    0x9007a034UL, 0x179fbcfbUL, 0x0e848dbaUL, 0x25a9de79UL, 0x3cb2ef38UL,+    0x73f379ffUL, 0x6ae848beUL, 0x41c51b7dUL, 0x58de2a3cUL, 0xf0794f05UL,+    0xe9627e44UL, 0xc24f2d87UL, 0xdb541cc6UL, 0x94158a01UL, 0x8d0ebb40UL,+    0xa623e883UL, 0xbf38d9c2UL, 0x38a0c50dUL, 0x21bbf44cUL, 0x0a96a78fUL,+    0x138d96ceUL, 0x5ccc0009UL, 0x45d73148UL, 0x6efa628bUL, 0x77e153caUL,+    0xbabb5d54UL, 0xa3a06c15UL, 0x888d3fd6UL, 0x91960e97UL, 0xded79850UL,+    0xc7cca911UL, 0xece1fad2UL, 0xf5facb93UL, 0x7262d75cUL, 0x6b79e61dUL,+    0x4054b5deUL, 0x594f849fUL, 0x160e1258UL, 0x0f152319UL, 0x243870daUL,+    0x3d23419bUL, 0x65fd6ba7UL, 0x7ce65ae6UL, 0x57cb0925UL, 0x4ed03864UL,+    0x0191aea3UL, 0x188a9fe2UL, 0x33a7cc21UL, 0x2abcfd60UL, 0xad24e1afUL,+    0xb43fd0eeUL, 0x9f12832dUL, 0x8609b26cUL, 0xc94824abUL, 0xd05315eaUL,+    0xfb7e4629UL, 0xe2657768UL, 0x2f3f79f6UL, 0x362448b7UL, 0x1d091b74UL,+    0x04122a35UL, 0x4b53bcf2UL, 0x52488db3UL, 0x7965de70UL, 0x607eef31UL,+    0xe7e6f3feUL, 0xfefdc2bfUL, 0xd5d0917cUL, 0xcccba03dUL, 0x838a36faUL,+    0x9a9107bbUL, 0xb1bc5478UL, 0xa8a76539UL, 0x3b83984bUL, 0x2298a90aUL,+    0x09b5fac9UL, 0x10aecb88UL, 0x5fef5d4fUL, 0x46f46c0eUL, 0x6dd93fcdUL,+    0x74c20e8cUL, 0xf35a1243UL, 0xea412302UL, 0xc16c70c1UL, 0xd8774180UL,+    0x9736d747UL, 0x8e2de606UL, 0xa500b5c5UL, 0xbc1b8484UL, 0x71418a1aUL,+    0x685abb5bUL, 0x4377e898UL, 0x5a6cd9d9UL, 0x152d4f1eUL, 0x0c367e5fUL,+    0x271b2d9cUL, 0x3e001cddUL, 0xb9980012UL, 0xa0833153UL, 0x8bae6290UL,+    0x92b553d1UL, 0xddf4c516UL, 0xc4eff457UL, 0xefc2a794UL, 0xf6d996d5UL,+    0xae07bce9UL, 0xb71c8da8UL, 0x9c31de6bUL, 0x852aef2aUL, 0xca6b79edUL,+    0xd37048acUL, 0xf85d1b6fUL, 0xe1462a2eUL, 0x66de36e1UL, 0x7fc507a0UL,+    0x54e85463UL, 0x4df36522UL, 0x02b2f3e5UL, 0x1ba9c2a4UL, 0x30849167UL,+    0x299fa026UL, 0xe4c5aeb8UL, 0xfdde9ff9UL, 0xd6f3cc3aUL, 0xcfe8fd7bUL,+    0x80a96bbcUL, 0x99b25afdUL, 0xb29f093eUL, 0xab84387fUL, 0x2c1c24b0UL,+    0x350715f1UL, 0x1e2a4632UL, 0x07317773UL, 0x4870e1b4UL, 0x516bd0f5UL,+    0x7a468336UL, 0x635db277UL, 0xcbfad74eUL, 0xd2e1e60fUL, 0xf9ccb5ccUL,+    0xe0d7848dUL, 0xaf96124aUL, 0xb68d230bUL, 0x9da070c8UL, 0x84bb4189UL,+    0x03235d46UL, 0x1a386c07UL, 0x31153fc4UL, 0x280e0e85UL, 0x674f9842UL,+    0x7e54a903UL, 0x5579fac0UL, 0x4c62cb81UL, 0x8138c51fUL, 0x9823f45eUL,+    0xb30ea79dUL, 0xaa1596dcUL, 0xe554001bUL, 0xfc4f315aUL, 0xd7626299UL,+    0xce7953d8UL, 0x49e14f17UL, 0x50fa7e56UL, 0x7bd72d95UL, 0x62cc1cd4UL,+    0x2d8d8a13UL, 0x3496bb52UL, 0x1fbbe891UL, 0x06a0d9d0UL, 0x5e7ef3ecUL,+    0x4765c2adUL, 0x6c48916eUL, 0x7553a02fUL, 0x3a1236e8UL, 0x230907a9UL,+    0x0824546aUL, 0x113f652bUL, 0x96a779e4UL, 0x8fbc48a5UL, 0xa4911b66UL,+    0xbd8a2a27UL, 0xf2cbbce0UL, 0xebd08da1UL, 0xc0fdde62UL, 0xd9e6ef23UL,+    0x14bce1bdUL, 0x0da7d0fcUL, 0x268a833fUL, 0x3f91b27eUL, 0x70d024b9UL,+    0x69cb15f8UL, 0x42e6463bUL, 0x5bfd777aUL, 0xdc656bb5UL, 0xc57e5af4UL,+    0xee530937UL, 0xf7483876UL, 0xb809aeb1UL, 0xa1129ff0UL, 0x8a3fcc33UL,+    0x9324fd72UL+  },+  {+    0x00000000UL, 0x01c26a37UL, 0x0384d46eUL, 0x0246be59UL, 0x0709a8dcUL,+    0x06cbc2ebUL, 0x048d7cb2UL, 0x054f1685UL, 0x0e1351b8UL, 0x0fd13b8fUL,+    0x0d9785d6UL, 0x0c55efe1UL, 0x091af964UL, 0x08d89353UL, 0x0a9e2d0aUL,+    0x0b5c473dUL, 0x1c26a370UL, 0x1de4c947UL, 0x1fa2771eUL, 0x1e601d29UL,+    0x1b2f0bacUL, 0x1aed619bUL, 0x18abdfc2UL, 0x1969b5f5UL, 0x1235f2c8UL,+    0x13f798ffUL, 0x11b126a6UL, 0x10734c91UL, 0x153c5a14UL, 0x14fe3023UL,+    0x16b88e7aUL, 0x177ae44dUL, 0x384d46e0UL, 0x398f2cd7UL, 0x3bc9928eUL,+    0x3a0bf8b9UL, 0x3f44ee3cUL, 0x3e86840bUL, 0x3cc03a52UL, 0x3d025065UL,+    0x365e1758UL, 0x379c7d6fUL, 0x35dac336UL, 0x3418a901UL, 0x3157bf84UL,+    0x3095d5b3UL, 0x32d36beaUL, 0x331101ddUL, 0x246be590UL, 0x25a98fa7UL,+    0x27ef31feUL, 0x262d5bc9UL, 0x23624d4cUL, 0x22a0277bUL, 0x20e69922UL,+    0x2124f315UL, 0x2a78b428UL, 0x2bbade1fUL, 0x29fc6046UL, 0x283e0a71UL,+    0x2d711cf4UL, 0x2cb376c3UL, 0x2ef5c89aUL, 0x2f37a2adUL, 0x709a8dc0UL,+    0x7158e7f7UL, 0x731e59aeUL, 0x72dc3399UL, 0x7793251cUL, 0x76514f2bUL,+    0x7417f172UL, 0x75d59b45UL, 0x7e89dc78UL, 0x7f4bb64fUL, 0x7d0d0816UL,+    0x7ccf6221UL, 0x798074a4UL, 0x78421e93UL, 0x7a04a0caUL, 0x7bc6cafdUL,+    0x6cbc2eb0UL, 0x6d7e4487UL, 0x6f38fadeUL, 0x6efa90e9UL, 0x6bb5866cUL,+    0x6a77ec5bUL, 0x68315202UL, 0x69f33835UL, 0x62af7f08UL, 0x636d153fUL,+    0x612bab66UL, 0x60e9c151UL, 0x65a6d7d4UL, 0x6464bde3UL, 0x662203baUL,+    0x67e0698dUL, 0x48d7cb20UL, 0x4915a117UL, 0x4b531f4eUL, 0x4a917579UL,+    0x4fde63fcUL, 0x4e1c09cbUL, 0x4c5ab792UL, 0x4d98dda5UL, 0x46c49a98UL,+    0x4706f0afUL, 0x45404ef6UL, 0x448224c1UL, 0x41cd3244UL, 0x400f5873UL,+    0x4249e62aUL, 0x438b8c1dUL, 0x54f16850UL, 0x55330267UL, 0x5775bc3eUL,+    0x56b7d609UL, 0x53f8c08cUL, 0x523aaabbUL, 0x507c14e2UL, 0x51be7ed5UL,+    0x5ae239e8UL, 0x5b2053dfUL, 0x5966ed86UL, 0x58a487b1UL, 0x5deb9134UL,+    0x5c29fb03UL, 0x5e6f455aUL, 0x5fad2f6dUL, 0xe1351b80UL, 0xe0f771b7UL,+    0xe2b1cfeeUL, 0xe373a5d9UL, 0xe63cb35cUL, 0xe7fed96bUL, 0xe5b86732UL,+    0xe47a0d05UL, 0xef264a38UL, 0xeee4200fUL, 0xeca29e56UL, 0xed60f461UL,+    0xe82fe2e4UL, 0xe9ed88d3UL, 0xebab368aUL, 0xea695cbdUL, 0xfd13b8f0UL,+    0xfcd1d2c7UL, 0xfe976c9eUL, 0xff5506a9UL, 0xfa1a102cUL, 0xfbd87a1bUL,+    0xf99ec442UL, 0xf85cae75UL, 0xf300e948UL, 0xf2c2837fUL, 0xf0843d26UL,+    0xf1465711UL, 0xf4094194UL, 0xf5cb2ba3UL, 0xf78d95faUL, 0xf64fffcdUL,+    0xd9785d60UL, 0xd8ba3757UL, 0xdafc890eUL, 0xdb3ee339UL, 0xde71f5bcUL,+    0xdfb39f8bUL, 0xddf521d2UL, 0xdc374be5UL, 0xd76b0cd8UL, 0xd6a966efUL,+    0xd4efd8b6UL, 0xd52db281UL, 0xd062a404UL, 0xd1a0ce33UL, 0xd3e6706aUL,+    0xd2241a5dUL, 0xc55efe10UL, 0xc49c9427UL, 0xc6da2a7eUL, 0xc7184049UL,+    0xc25756ccUL, 0xc3953cfbUL, 0xc1d382a2UL, 0xc011e895UL, 0xcb4dafa8UL,+    0xca8fc59fUL, 0xc8c97bc6UL, 0xc90b11f1UL, 0xcc440774UL, 0xcd866d43UL,+    0xcfc0d31aUL, 0xce02b92dUL, 0x91af9640UL, 0x906dfc77UL, 0x922b422eUL,+    0x93e92819UL, 0x96a63e9cUL, 0x976454abUL, 0x9522eaf2UL, 0x94e080c5UL,+    0x9fbcc7f8UL, 0x9e7eadcfUL, 0x9c381396UL, 0x9dfa79a1UL, 0x98b56f24UL,+    0x99770513UL, 0x9b31bb4aUL, 0x9af3d17dUL, 0x8d893530UL, 0x8c4b5f07UL,+    0x8e0de15eUL, 0x8fcf8b69UL, 0x8a809decUL, 0x8b42f7dbUL, 0x89044982UL,+    0x88c623b5UL, 0x839a6488UL, 0x82580ebfUL, 0x801eb0e6UL, 0x81dcdad1UL,+    0x8493cc54UL, 0x8551a663UL, 0x8717183aUL, 0x86d5720dUL, 0xa9e2d0a0UL,+    0xa820ba97UL, 0xaa6604ceUL, 0xaba46ef9UL, 0xaeeb787cUL, 0xaf29124bUL,+    0xad6fac12UL, 0xacadc625UL, 0xa7f18118UL, 0xa633eb2fUL, 0xa4755576UL,+    0xa5b73f41UL, 0xa0f829c4UL, 0xa13a43f3UL, 0xa37cfdaaUL, 0xa2be979dUL,+    0xb5c473d0UL, 0xb40619e7UL, 0xb640a7beUL, 0xb782cd89UL, 0xb2cddb0cUL,+    0xb30fb13bUL, 0xb1490f62UL, 0xb08b6555UL, 0xbbd72268UL, 0xba15485fUL,+    0xb853f606UL, 0xb9919c31UL, 0xbcde8ab4UL, 0xbd1ce083UL, 0xbf5a5edaUL,+    0xbe9834edUL+  },+  {+    0x00000000UL, 0xb8bc6765UL, 0xaa09c88bUL, 0x12b5afeeUL, 0x8f629757UL,+    0x37def032UL, 0x256b5fdcUL, 0x9dd738b9UL, 0xc5b428efUL, 0x7d084f8aUL,+    0x6fbde064UL, 0xd7018701UL, 0x4ad6bfb8UL, 0xf26ad8ddUL, 0xe0df7733UL,+    0x58631056UL, 0x5019579fUL, 0xe8a530faUL, 0xfa109f14UL, 0x42acf871UL,+    0xdf7bc0c8UL, 0x67c7a7adUL, 0x75720843UL, 0xcdce6f26UL, 0x95ad7f70UL,+    0x2d111815UL, 0x3fa4b7fbUL, 0x8718d09eUL, 0x1acfe827UL, 0xa2738f42UL,+    0xb0c620acUL, 0x087a47c9UL, 0xa032af3eUL, 0x188ec85bUL, 0x0a3b67b5UL,+    0xb28700d0UL, 0x2f503869UL, 0x97ec5f0cUL, 0x8559f0e2UL, 0x3de59787UL,+    0x658687d1UL, 0xdd3ae0b4UL, 0xcf8f4f5aUL, 0x7733283fUL, 0xeae41086UL,+    0x525877e3UL, 0x40edd80dUL, 0xf851bf68UL, 0xf02bf8a1UL, 0x48979fc4UL,+    0x5a22302aUL, 0xe29e574fUL, 0x7f496ff6UL, 0xc7f50893UL, 0xd540a77dUL,+    0x6dfcc018UL, 0x359fd04eUL, 0x8d23b72bUL, 0x9f9618c5UL, 0x272a7fa0UL,+    0xbafd4719UL, 0x0241207cUL, 0x10f48f92UL, 0xa848e8f7UL, 0x9b14583dUL,+    0x23a83f58UL, 0x311d90b6UL, 0x89a1f7d3UL, 0x1476cf6aUL, 0xaccaa80fUL,+    0xbe7f07e1UL, 0x06c36084UL, 0x5ea070d2UL, 0xe61c17b7UL, 0xf4a9b859UL,+    0x4c15df3cUL, 0xd1c2e785UL, 0x697e80e0UL, 0x7bcb2f0eUL, 0xc377486bUL,+    0xcb0d0fa2UL, 0x73b168c7UL, 0x6104c729UL, 0xd9b8a04cUL, 0x446f98f5UL,+    0xfcd3ff90UL, 0xee66507eUL, 0x56da371bUL, 0x0eb9274dUL, 0xb6054028UL,+    0xa4b0efc6UL, 0x1c0c88a3UL, 0x81dbb01aUL, 0x3967d77fUL, 0x2bd27891UL,+    0x936e1ff4UL, 0x3b26f703UL, 0x839a9066UL, 0x912f3f88UL, 0x299358edUL,+    0xb4446054UL, 0x0cf80731UL, 0x1e4da8dfUL, 0xa6f1cfbaUL, 0xfe92dfecUL,+    0x462eb889UL, 0x549b1767UL, 0xec277002UL, 0x71f048bbUL, 0xc94c2fdeUL,+    0xdbf98030UL, 0x6345e755UL, 0x6b3fa09cUL, 0xd383c7f9UL, 0xc1366817UL,+    0x798a0f72UL, 0xe45d37cbUL, 0x5ce150aeUL, 0x4e54ff40UL, 0xf6e89825UL,+    0xae8b8873UL, 0x1637ef16UL, 0x048240f8UL, 0xbc3e279dUL, 0x21e91f24UL,+    0x99557841UL, 0x8be0d7afUL, 0x335cb0caUL, 0xed59b63bUL, 0x55e5d15eUL,+    0x47507eb0UL, 0xffec19d5UL, 0x623b216cUL, 0xda874609UL, 0xc832e9e7UL,+    0x708e8e82UL, 0x28ed9ed4UL, 0x9051f9b1UL, 0x82e4565fUL, 0x3a58313aUL,+    0xa78f0983UL, 0x1f336ee6UL, 0x0d86c108UL, 0xb53aa66dUL, 0xbd40e1a4UL,+    0x05fc86c1UL, 0x1749292fUL, 0xaff54e4aUL, 0x322276f3UL, 0x8a9e1196UL,+    0x982bbe78UL, 0x2097d91dUL, 0x78f4c94bUL, 0xc048ae2eUL, 0xd2fd01c0UL,+    0x6a4166a5UL, 0xf7965e1cUL, 0x4f2a3979UL, 0x5d9f9697UL, 0xe523f1f2UL,+    0x4d6b1905UL, 0xf5d77e60UL, 0xe762d18eUL, 0x5fdeb6ebUL, 0xc2098e52UL,+    0x7ab5e937UL, 0x680046d9UL, 0xd0bc21bcUL, 0x88df31eaUL, 0x3063568fUL,+    0x22d6f961UL, 0x9a6a9e04UL, 0x07bda6bdUL, 0xbf01c1d8UL, 0xadb46e36UL,+    0x15080953UL, 0x1d724e9aUL, 0xa5ce29ffUL, 0xb77b8611UL, 0x0fc7e174UL,+    0x9210d9cdUL, 0x2aacbea8UL, 0x38191146UL, 0x80a57623UL, 0xd8c66675UL,+    0x607a0110UL, 0x72cfaefeUL, 0xca73c99bUL, 0x57a4f122UL, 0xef189647UL,+    0xfdad39a9UL, 0x45115eccUL, 0x764dee06UL, 0xcef18963UL, 0xdc44268dUL,+    0x64f841e8UL, 0xf92f7951UL, 0x41931e34UL, 0x5326b1daUL, 0xeb9ad6bfUL,+    0xb3f9c6e9UL, 0x0b45a18cUL, 0x19f00e62UL, 0xa14c6907UL, 0x3c9b51beUL,+    0x842736dbUL, 0x96929935UL, 0x2e2efe50UL, 0x2654b999UL, 0x9ee8defcUL,+    0x8c5d7112UL, 0x34e11677UL, 0xa9362eceUL, 0x118a49abUL, 0x033fe645UL,+    0xbb838120UL, 0xe3e09176UL, 0x5b5cf613UL, 0x49e959fdUL, 0xf1553e98UL,+    0x6c820621UL, 0xd43e6144UL, 0xc68bceaaUL, 0x7e37a9cfUL, 0xd67f4138UL,+    0x6ec3265dUL, 0x7c7689b3UL, 0xc4caeed6UL, 0x591dd66fUL, 0xe1a1b10aUL,+    0xf3141ee4UL, 0x4ba87981UL, 0x13cb69d7UL, 0xab770eb2UL, 0xb9c2a15cUL,+    0x017ec639UL, 0x9ca9fe80UL, 0x241599e5UL, 0x36a0360bUL, 0x8e1c516eUL,+    0x866616a7UL, 0x3eda71c2UL, 0x2c6fde2cUL, 0x94d3b949UL, 0x090481f0UL,+    0xb1b8e695UL, 0xa30d497bUL, 0x1bb12e1eUL, 0x43d23e48UL, 0xfb6e592dUL,+    0xe9dbf6c3UL, 0x516791a6UL, 0xccb0a91fUL, 0x740cce7aUL, 0x66b96194UL,+    0xde0506f1UL+  },+  {+    0x00000000UL, 0x96300777UL, 0x2c610eeeUL, 0xba510999UL, 0x19c46d07UL,+    0x8ff46a70UL, 0x35a563e9UL, 0xa395649eUL, 0x3288db0eUL, 0xa4b8dc79UL,+    0x1ee9d5e0UL, 0x88d9d297UL, 0x2b4cb609UL, 0xbd7cb17eUL, 0x072db8e7UL,+    0x911dbf90UL, 0x6410b71dUL, 0xf220b06aUL, 0x4871b9f3UL, 0xde41be84UL,+    0x7dd4da1aUL, 0xebe4dd6dUL, 0x51b5d4f4UL, 0xc785d383UL, 0x56986c13UL,+    0xc0a86b64UL, 0x7af962fdUL, 0xecc9658aUL, 0x4f5c0114UL, 0xd96c0663UL,+    0x633d0ffaUL, 0xf50d088dUL, 0xc8206e3bUL, 0x5e10694cUL, 0xe44160d5UL,+    0x727167a2UL, 0xd1e4033cUL, 0x47d4044bUL, 0xfd850dd2UL, 0x6bb50aa5UL,+    0xfaa8b535UL, 0x6c98b242UL, 0xd6c9bbdbUL, 0x40f9bcacUL, 0xe36cd832UL,+    0x755cdf45UL, 0xcf0dd6dcUL, 0x593dd1abUL, 0xac30d926UL, 0x3a00de51UL,+    0x8051d7c8UL, 0x1661d0bfUL, 0xb5f4b421UL, 0x23c4b356UL, 0x9995bacfUL,+    0x0fa5bdb8UL, 0x9eb80228UL, 0x0888055fUL, 0xb2d90cc6UL, 0x24e90bb1UL,+    0x877c6f2fUL, 0x114c6858UL, 0xab1d61c1UL, 0x3d2d66b6UL, 0x9041dc76UL,+    0x0671db01UL, 0xbc20d298UL, 0x2a10d5efUL, 0x8985b171UL, 0x1fb5b606UL,+    0xa5e4bf9fUL, 0x33d4b8e8UL, 0xa2c90778UL, 0x34f9000fUL, 0x8ea80996UL,+    0x18980ee1UL, 0xbb0d6a7fUL, 0x2d3d6d08UL, 0x976c6491UL, 0x015c63e6UL,+    0xf4516b6bUL, 0x62616c1cUL, 0xd8306585UL, 0x4e0062f2UL, 0xed95066cUL,+    0x7ba5011bUL, 0xc1f40882UL, 0x57c40ff5UL, 0xc6d9b065UL, 0x50e9b712UL,+    0xeab8be8bUL, 0x7c88b9fcUL, 0xdf1ddd62UL, 0x492dda15UL, 0xf37cd38cUL,+    0x654cd4fbUL, 0x5861b24dUL, 0xce51b53aUL, 0x7400bca3UL, 0xe230bbd4UL,+    0x41a5df4aUL, 0xd795d83dUL, 0x6dc4d1a4UL, 0xfbf4d6d3UL, 0x6ae96943UL,+    0xfcd96e34UL, 0x468867adUL, 0xd0b860daUL, 0x732d0444UL, 0xe51d0333UL,+    0x5f4c0aaaUL, 0xc97c0dddUL, 0x3c710550UL, 0xaa410227UL, 0x10100bbeUL,+    0x86200cc9UL, 0x25b56857UL, 0xb3856f20UL, 0x09d466b9UL, 0x9fe461ceUL,+    0x0ef9de5eUL, 0x98c9d929UL, 0x2298d0b0UL, 0xb4a8d7c7UL, 0x173db359UL,+    0x810db42eUL, 0x3b5cbdb7UL, 0xad6cbac0UL, 0x2083b8edUL, 0xb6b3bf9aUL,+    0x0ce2b603UL, 0x9ad2b174UL, 0x3947d5eaUL, 0xaf77d29dUL, 0x1526db04UL,+    0x8316dc73UL, 0x120b63e3UL, 0x843b6494UL, 0x3e6a6d0dUL, 0xa85a6a7aUL,+    0x0bcf0ee4UL, 0x9dff0993UL, 0x27ae000aUL, 0xb19e077dUL, 0x44930ff0UL,+    0xd2a30887UL, 0x68f2011eUL, 0xfec20669UL, 0x5d5762f7UL, 0xcb676580UL,+    0x71366c19UL, 0xe7066b6eUL, 0x761bd4feUL, 0xe02bd389UL, 0x5a7ada10UL,+    0xcc4add67UL, 0x6fdfb9f9UL, 0xf9efbe8eUL, 0x43beb717UL, 0xd58eb060UL,+    0xe8a3d6d6UL, 0x7e93d1a1UL, 0xc4c2d838UL, 0x52f2df4fUL, 0xf167bbd1UL,+    0x6757bca6UL, 0xdd06b53fUL, 0x4b36b248UL, 0xda2b0dd8UL, 0x4c1b0aafUL,+    0xf64a0336UL, 0x607a0441UL, 0xc3ef60dfUL, 0x55df67a8UL, 0xef8e6e31UL,+    0x79be6946UL, 0x8cb361cbUL, 0x1a8366bcUL, 0xa0d26f25UL, 0x36e26852UL,+    0x95770cccUL, 0x03470bbbUL, 0xb9160222UL, 0x2f260555UL, 0xbe3bbac5UL,+    0x280bbdb2UL, 0x925ab42bUL, 0x046ab35cUL, 0xa7ffd7c2UL, 0x31cfd0b5UL,+    0x8b9ed92cUL, 0x1daede5bUL, 0xb0c2649bUL, 0x26f263ecUL, 0x9ca36a75UL,+    0x0a936d02UL, 0xa906099cUL, 0x3f360eebUL, 0x85670772UL, 0x13570005UL,+    0x824abf95UL, 0x147ab8e2UL, 0xae2bb17bUL, 0x381bb60cUL, 0x9b8ed292UL,+    0x0dbed5e5UL, 0xb7efdc7cUL, 0x21dfdb0bUL, 0xd4d2d386UL, 0x42e2d4f1UL,+    0xf8b3dd68UL, 0x6e83da1fUL, 0xcd16be81UL, 0x5b26b9f6UL, 0xe177b06fUL,+    0x7747b718UL, 0xe65a0888UL, 0x706a0fffUL, 0xca3b0666UL, 0x5c0b0111UL,+    0xff9e658fUL, 0x69ae62f8UL, 0xd3ff6b61UL, 0x45cf6c16UL, 0x78e20aa0UL,+    0xeed20dd7UL, 0x5483044eUL, 0xc2b30339UL, 0x612667a7UL, 0xf71660d0UL,+    0x4d476949UL, 0xdb776e3eUL, 0x4a6ad1aeUL, 0xdc5ad6d9UL, 0x660bdf40UL,+    0xf03bd837UL, 0x53aebca9UL, 0xc59ebbdeUL, 0x7fcfb247UL, 0xe9ffb530UL,+    0x1cf2bdbdUL, 0x8ac2bacaUL, 0x3093b353UL, 0xa6a3b424UL, 0x0536d0baUL,+    0x9306d7cdUL, 0x2957de54UL, 0xbf67d923UL, 0x2e7a66b3UL, 0xb84a61c4UL,+    0x021b685dUL, 0x942b6f2aUL, 0x37be0bb4UL, 0xa18e0cc3UL, 0x1bdf055aUL,+    0x8def022dUL+  },+  {+    0x00000000UL, 0x41311b19UL, 0x82623632UL, 0xc3532d2bUL, 0x04c56c64UL,+    0x45f4777dUL, 0x86a75a56UL, 0xc796414fUL, 0x088ad9c8UL, 0x49bbc2d1UL,+    0x8ae8effaUL, 0xcbd9f4e3UL, 0x0c4fb5acUL, 0x4d7eaeb5UL, 0x8e2d839eUL,+    0xcf1c9887UL, 0x5112c24aUL, 0x1023d953UL, 0xd370f478UL, 0x9241ef61UL,+    0x55d7ae2eUL, 0x14e6b537UL, 0xd7b5981cUL, 0x96848305UL, 0x59981b82UL,+    0x18a9009bUL, 0xdbfa2db0UL, 0x9acb36a9UL, 0x5d5d77e6UL, 0x1c6c6cffUL,+    0xdf3f41d4UL, 0x9e0e5acdUL, 0xa2248495UL, 0xe3159f8cUL, 0x2046b2a7UL,+    0x6177a9beUL, 0xa6e1e8f1UL, 0xe7d0f3e8UL, 0x2483dec3UL, 0x65b2c5daUL,+    0xaaae5d5dUL, 0xeb9f4644UL, 0x28cc6b6fUL, 0x69fd7076UL, 0xae6b3139UL,+    0xef5a2a20UL, 0x2c09070bUL, 0x6d381c12UL, 0xf33646dfUL, 0xb2075dc6UL,+    0x715470edUL, 0x30656bf4UL, 0xf7f32abbUL, 0xb6c231a2UL, 0x75911c89UL,+    0x34a00790UL, 0xfbbc9f17UL, 0xba8d840eUL, 0x79dea925UL, 0x38efb23cUL,+    0xff79f373UL, 0xbe48e86aUL, 0x7d1bc541UL, 0x3c2ade58UL, 0x054f79f0UL,+    0x447e62e9UL, 0x872d4fc2UL, 0xc61c54dbUL, 0x018a1594UL, 0x40bb0e8dUL,+    0x83e823a6UL, 0xc2d938bfUL, 0x0dc5a038UL, 0x4cf4bb21UL, 0x8fa7960aUL,+    0xce968d13UL, 0x0900cc5cUL, 0x4831d745UL, 0x8b62fa6eUL, 0xca53e177UL,+    0x545dbbbaUL, 0x156ca0a3UL, 0xd63f8d88UL, 0x970e9691UL, 0x5098d7deUL,+    0x11a9ccc7UL, 0xd2fae1ecUL, 0x93cbfaf5UL, 0x5cd76272UL, 0x1de6796bUL,+    0xdeb55440UL, 0x9f844f59UL, 0x58120e16UL, 0x1923150fUL, 0xda703824UL,+    0x9b41233dUL, 0xa76bfd65UL, 0xe65ae67cUL, 0x2509cb57UL, 0x6438d04eUL,+    0xa3ae9101UL, 0xe29f8a18UL, 0x21cca733UL, 0x60fdbc2aUL, 0xafe124adUL,+    0xeed03fb4UL, 0x2d83129fUL, 0x6cb20986UL, 0xab2448c9UL, 0xea1553d0UL,+    0x29467efbUL, 0x687765e2UL, 0xf6793f2fUL, 0xb7482436UL, 0x741b091dUL,+    0x352a1204UL, 0xf2bc534bUL, 0xb38d4852UL, 0x70de6579UL, 0x31ef7e60UL,+    0xfef3e6e7UL, 0xbfc2fdfeUL, 0x7c91d0d5UL, 0x3da0cbccUL, 0xfa368a83UL,+    0xbb07919aUL, 0x7854bcb1UL, 0x3965a7a8UL, 0x4b98833bUL, 0x0aa99822UL,+    0xc9fab509UL, 0x88cbae10UL, 0x4f5def5fUL, 0x0e6cf446UL, 0xcd3fd96dUL,+    0x8c0ec274UL, 0x43125af3UL, 0x022341eaUL, 0xc1706cc1UL, 0x804177d8UL,+    0x47d73697UL, 0x06e62d8eUL, 0xc5b500a5UL, 0x84841bbcUL, 0x1a8a4171UL,+    0x5bbb5a68UL, 0x98e87743UL, 0xd9d96c5aUL, 0x1e4f2d15UL, 0x5f7e360cUL,+    0x9c2d1b27UL, 0xdd1c003eUL, 0x120098b9UL, 0x533183a0UL, 0x9062ae8bUL,+    0xd153b592UL, 0x16c5f4ddUL, 0x57f4efc4UL, 0x94a7c2efUL, 0xd596d9f6UL,+    0xe9bc07aeUL, 0xa88d1cb7UL, 0x6bde319cUL, 0x2aef2a85UL, 0xed796bcaUL,+    0xac4870d3UL, 0x6f1b5df8UL, 0x2e2a46e1UL, 0xe136de66UL, 0xa007c57fUL,+    0x6354e854UL, 0x2265f34dUL, 0xe5f3b202UL, 0xa4c2a91bUL, 0x67918430UL,+    0x26a09f29UL, 0xb8aec5e4UL, 0xf99fdefdUL, 0x3accf3d6UL, 0x7bfde8cfUL,+    0xbc6ba980UL, 0xfd5ab299UL, 0x3e099fb2UL, 0x7f3884abUL, 0xb0241c2cUL,+    0xf1150735UL, 0x32462a1eUL, 0x73773107UL, 0xb4e17048UL, 0xf5d06b51UL,+    0x3683467aUL, 0x77b25d63UL, 0x4ed7facbUL, 0x0fe6e1d2UL, 0xccb5ccf9UL,+    0x8d84d7e0UL, 0x4a1296afUL, 0x0b238db6UL, 0xc870a09dUL, 0x8941bb84UL,+    0x465d2303UL, 0x076c381aUL, 0xc43f1531UL, 0x850e0e28UL, 0x42984f67UL,+    0x03a9547eUL, 0xc0fa7955UL, 0x81cb624cUL, 0x1fc53881UL, 0x5ef42398UL,+    0x9da70eb3UL, 0xdc9615aaUL, 0x1b0054e5UL, 0x5a314ffcUL, 0x996262d7UL,+    0xd85379ceUL, 0x174fe149UL, 0x567efa50UL, 0x952dd77bUL, 0xd41ccc62UL,+    0x138a8d2dUL, 0x52bb9634UL, 0x91e8bb1fUL, 0xd0d9a006UL, 0xecf37e5eUL,+    0xadc26547UL, 0x6e91486cUL, 0x2fa05375UL, 0xe836123aUL, 0xa9070923UL,+    0x6a542408UL, 0x2b653f11UL, 0xe479a796UL, 0xa548bc8fUL, 0x661b91a4UL,+    0x272a8abdUL, 0xe0bccbf2UL, 0xa18dd0ebUL, 0x62defdc0UL, 0x23efe6d9UL,+    0xbde1bc14UL, 0xfcd0a70dUL, 0x3f838a26UL, 0x7eb2913fUL, 0xb924d070UL,+    0xf815cb69UL, 0x3b46e642UL, 0x7a77fd5bUL, 0xb56b65dcUL, 0xf45a7ec5UL,+    0x370953eeUL, 0x763848f7UL, 0xb1ae09b8UL, 0xf09f12a1UL, 0x33cc3f8aUL,+    0x72fd2493UL+  },+  {+    0x00000000UL, 0x376ac201UL, 0x6ed48403UL, 0x59be4602UL, 0xdca80907UL,+    0xebc2cb06UL, 0xb27c8d04UL, 0x85164f05UL, 0xb851130eUL, 0x8f3bd10fUL,+    0xd685970dUL, 0xe1ef550cUL, 0x64f91a09UL, 0x5393d808UL, 0x0a2d9e0aUL,+    0x3d475c0bUL, 0x70a3261cUL, 0x47c9e41dUL, 0x1e77a21fUL, 0x291d601eUL,+    0xac0b2f1bUL, 0x9b61ed1aUL, 0xc2dfab18UL, 0xf5b56919UL, 0xc8f23512UL,+    0xff98f713UL, 0xa626b111UL, 0x914c7310UL, 0x145a3c15UL, 0x2330fe14UL,+    0x7a8eb816UL, 0x4de47a17UL, 0xe0464d38UL, 0xd72c8f39UL, 0x8e92c93bUL,+    0xb9f80b3aUL, 0x3cee443fUL, 0x0b84863eUL, 0x523ac03cUL, 0x6550023dUL,+    0x58175e36UL, 0x6f7d9c37UL, 0x36c3da35UL, 0x01a91834UL, 0x84bf5731UL,+    0xb3d59530UL, 0xea6bd332UL, 0xdd011133UL, 0x90e56b24UL, 0xa78fa925UL,+    0xfe31ef27UL, 0xc95b2d26UL, 0x4c4d6223UL, 0x7b27a022UL, 0x2299e620UL,+    0x15f32421UL, 0x28b4782aUL, 0x1fdeba2bUL, 0x4660fc29UL, 0x710a3e28UL,+    0xf41c712dUL, 0xc376b32cUL, 0x9ac8f52eUL, 0xada2372fUL, 0xc08d9a70UL,+    0xf7e75871UL, 0xae591e73UL, 0x9933dc72UL, 0x1c259377UL, 0x2b4f5176UL,+    0x72f11774UL, 0x459bd575UL, 0x78dc897eUL, 0x4fb64b7fUL, 0x16080d7dUL,+    0x2162cf7cUL, 0xa4748079UL, 0x931e4278UL, 0xcaa0047aUL, 0xfdcac67bUL,+    0xb02ebc6cUL, 0x87447e6dUL, 0xdefa386fUL, 0xe990fa6eUL, 0x6c86b56bUL,+    0x5bec776aUL, 0x02523168UL, 0x3538f369UL, 0x087faf62UL, 0x3f156d63UL,+    0x66ab2b61UL, 0x51c1e960UL, 0xd4d7a665UL, 0xe3bd6464UL, 0xba032266UL,+    0x8d69e067UL, 0x20cbd748UL, 0x17a11549UL, 0x4e1f534bUL, 0x7975914aUL,+    0xfc63de4fUL, 0xcb091c4eUL, 0x92b75a4cUL, 0xa5dd984dUL, 0x989ac446UL,+    0xaff00647UL, 0xf64e4045UL, 0xc1248244UL, 0x4432cd41UL, 0x73580f40UL,+    0x2ae64942UL, 0x1d8c8b43UL, 0x5068f154UL, 0x67023355UL, 0x3ebc7557UL,+    0x09d6b756UL, 0x8cc0f853UL, 0xbbaa3a52UL, 0xe2147c50UL, 0xd57ebe51UL,+    0xe839e25aUL, 0xdf53205bUL, 0x86ed6659UL, 0xb187a458UL, 0x3491eb5dUL,+    0x03fb295cUL, 0x5a456f5eUL, 0x6d2fad5fUL, 0x801b35e1UL, 0xb771f7e0UL,+    0xeecfb1e2UL, 0xd9a573e3UL, 0x5cb33ce6UL, 0x6bd9fee7UL, 0x3267b8e5UL,+    0x050d7ae4UL, 0x384a26efUL, 0x0f20e4eeUL, 0x569ea2ecUL, 0x61f460edUL,+    0xe4e22fe8UL, 0xd388ede9UL, 0x8a36abebUL, 0xbd5c69eaUL, 0xf0b813fdUL,+    0xc7d2d1fcUL, 0x9e6c97feUL, 0xa90655ffUL, 0x2c101afaUL, 0x1b7ad8fbUL,+    0x42c49ef9UL, 0x75ae5cf8UL, 0x48e900f3UL, 0x7f83c2f2UL, 0x263d84f0UL,+    0x115746f1UL, 0x944109f4UL, 0xa32bcbf5UL, 0xfa958df7UL, 0xcdff4ff6UL,+    0x605d78d9UL, 0x5737bad8UL, 0x0e89fcdaUL, 0x39e33edbUL, 0xbcf571deUL,+    0x8b9fb3dfUL, 0xd221f5ddUL, 0xe54b37dcUL, 0xd80c6bd7UL, 0xef66a9d6UL,+    0xb6d8efd4UL, 0x81b22dd5UL, 0x04a462d0UL, 0x33cea0d1UL, 0x6a70e6d3UL,+    0x5d1a24d2UL, 0x10fe5ec5UL, 0x27949cc4UL, 0x7e2adac6UL, 0x494018c7UL,+    0xcc5657c2UL, 0xfb3c95c3UL, 0xa282d3c1UL, 0x95e811c0UL, 0xa8af4dcbUL,+    0x9fc58fcaUL, 0xc67bc9c8UL, 0xf1110bc9UL, 0x740744ccUL, 0x436d86cdUL,+    0x1ad3c0cfUL, 0x2db902ceUL, 0x4096af91UL, 0x77fc6d90UL, 0x2e422b92UL,+    0x1928e993UL, 0x9c3ea696UL, 0xab546497UL, 0xf2ea2295UL, 0xc580e094UL,+    0xf8c7bc9fUL, 0xcfad7e9eUL, 0x9613389cUL, 0xa179fa9dUL, 0x246fb598UL,+    0x13057799UL, 0x4abb319bUL, 0x7dd1f39aUL, 0x3035898dUL, 0x075f4b8cUL,+    0x5ee10d8eUL, 0x698bcf8fUL, 0xec9d808aUL, 0xdbf7428bUL, 0x82490489UL,+    0xb523c688UL, 0x88649a83UL, 0xbf0e5882UL, 0xe6b01e80UL, 0xd1dadc81UL,+    0x54cc9384UL, 0x63a65185UL, 0x3a181787UL, 0x0d72d586UL, 0xa0d0e2a9UL,+    0x97ba20a8UL, 0xce0466aaUL, 0xf96ea4abUL, 0x7c78ebaeUL, 0x4b1229afUL,+    0x12ac6fadUL, 0x25c6adacUL, 0x1881f1a7UL, 0x2feb33a6UL, 0x765575a4UL,+    0x413fb7a5UL, 0xc429f8a0UL, 0xf3433aa1UL, 0xaafd7ca3UL, 0x9d97bea2UL,+    0xd073c4b5UL, 0xe71906b4UL, 0xbea740b6UL, 0x89cd82b7UL, 0x0cdbcdb2UL,+    0x3bb10fb3UL, 0x620f49b1UL, 0x55658bb0UL, 0x6822d7bbUL, 0x5f4815baUL,+    0x06f653b8UL, 0x319c91b9UL, 0xb48adebcUL, 0x83e01cbdUL, 0xda5e5abfUL,+    0xed3498beUL+  },+  {+    0x00000000UL, 0x6567bcb8UL, 0x8bc809aaUL, 0xeeafb512UL, 0x5797628fUL,+    0x32f0de37UL, 0xdc5f6b25UL, 0xb938d79dUL, 0xef28b4c5UL, 0x8a4f087dUL,+    0x64e0bd6fUL, 0x018701d7UL, 0xb8bfd64aUL, 0xddd86af2UL, 0x3377dfe0UL,+    0x56106358UL, 0x9f571950UL, 0xfa30a5e8UL, 0x149f10faUL, 0x71f8ac42UL,+    0xc8c07bdfUL, 0xada7c767UL, 0x43087275UL, 0x266fcecdUL, 0x707fad95UL,+    0x1518112dUL, 0xfbb7a43fUL, 0x9ed01887UL, 0x27e8cf1aUL, 0x428f73a2UL,+    0xac20c6b0UL, 0xc9477a08UL, 0x3eaf32a0UL, 0x5bc88e18UL, 0xb5673b0aUL,+    0xd00087b2UL, 0x6938502fUL, 0x0c5fec97UL, 0xe2f05985UL, 0x8797e53dUL,+    0xd1878665UL, 0xb4e03addUL, 0x5a4f8fcfUL, 0x3f283377UL, 0x8610e4eaUL,+    0xe3775852UL, 0x0dd8ed40UL, 0x68bf51f8UL, 0xa1f82bf0UL, 0xc49f9748UL,+    0x2a30225aUL, 0x4f579ee2UL, 0xf66f497fUL, 0x9308f5c7UL, 0x7da740d5UL,+    0x18c0fc6dUL, 0x4ed09f35UL, 0x2bb7238dUL, 0xc518969fUL, 0xa07f2a27UL,+    0x1947fdbaUL, 0x7c204102UL, 0x928ff410UL, 0xf7e848a8UL, 0x3d58149bUL,+    0x583fa823UL, 0xb6901d31UL, 0xd3f7a189UL, 0x6acf7614UL, 0x0fa8caacUL,+    0xe1077fbeUL, 0x8460c306UL, 0xd270a05eUL, 0xb7171ce6UL, 0x59b8a9f4UL,+    0x3cdf154cUL, 0x85e7c2d1UL, 0xe0807e69UL, 0x0e2fcb7bUL, 0x6b4877c3UL,+    0xa20f0dcbUL, 0xc768b173UL, 0x29c70461UL, 0x4ca0b8d9UL, 0xf5986f44UL,+    0x90ffd3fcUL, 0x7e5066eeUL, 0x1b37da56UL, 0x4d27b90eUL, 0x284005b6UL,+    0xc6efb0a4UL, 0xa3880c1cUL, 0x1ab0db81UL, 0x7fd76739UL, 0x9178d22bUL,+    0xf41f6e93UL, 0x03f7263bUL, 0x66909a83UL, 0x883f2f91UL, 0xed589329UL,+    0x546044b4UL, 0x3107f80cUL, 0xdfa84d1eUL, 0xbacff1a6UL, 0xecdf92feUL,+    0x89b82e46UL, 0x67179b54UL, 0x027027ecUL, 0xbb48f071UL, 0xde2f4cc9UL,+    0x3080f9dbUL, 0x55e74563UL, 0x9ca03f6bUL, 0xf9c783d3UL, 0x176836c1UL,+    0x720f8a79UL, 0xcb375de4UL, 0xae50e15cUL, 0x40ff544eUL, 0x2598e8f6UL,+    0x73888baeUL, 0x16ef3716UL, 0xf8408204UL, 0x9d273ebcUL, 0x241fe921UL,+    0x41785599UL, 0xafd7e08bUL, 0xcab05c33UL, 0x3bb659edUL, 0x5ed1e555UL,+    0xb07e5047UL, 0xd519ecffUL, 0x6c213b62UL, 0x094687daUL, 0xe7e932c8UL,+    0x828e8e70UL, 0xd49eed28UL, 0xb1f95190UL, 0x5f56e482UL, 0x3a31583aUL,+    0x83098fa7UL, 0xe66e331fUL, 0x08c1860dUL, 0x6da63ab5UL, 0xa4e140bdUL,+    0xc186fc05UL, 0x2f294917UL, 0x4a4ef5afUL, 0xf3762232UL, 0x96119e8aUL,+    0x78be2b98UL, 0x1dd99720UL, 0x4bc9f478UL, 0x2eae48c0UL, 0xc001fdd2UL,+    0xa566416aUL, 0x1c5e96f7UL, 0x79392a4fUL, 0x97969f5dUL, 0xf2f123e5UL,+    0x05196b4dUL, 0x607ed7f5UL, 0x8ed162e7UL, 0xebb6de5fUL, 0x528e09c2UL,+    0x37e9b57aUL, 0xd9460068UL, 0xbc21bcd0UL, 0xea31df88UL, 0x8f566330UL,+    0x61f9d622UL, 0x049e6a9aUL, 0xbda6bd07UL, 0xd8c101bfUL, 0x366eb4adUL,+    0x53090815UL, 0x9a4e721dUL, 0xff29cea5UL, 0x11867bb7UL, 0x74e1c70fUL,+    0xcdd91092UL, 0xa8beac2aUL, 0x46111938UL, 0x2376a580UL, 0x7566c6d8UL,+    0x10017a60UL, 0xfeaecf72UL, 0x9bc973caUL, 0x22f1a457UL, 0x479618efUL,+    0xa939adfdUL, 0xcc5e1145UL, 0x06ee4d76UL, 0x6389f1ceUL, 0x8d2644dcUL,+    0xe841f864UL, 0x51792ff9UL, 0x341e9341UL, 0xdab12653UL, 0xbfd69aebUL,+    0xe9c6f9b3UL, 0x8ca1450bUL, 0x620ef019UL, 0x07694ca1UL, 0xbe519b3cUL,+    0xdb362784UL, 0x35999296UL, 0x50fe2e2eUL, 0x99b95426UL, 0xfcdee89eUL,+    0x12715d8cUL, 0x7716e134UL, 0xce2e36a9UL, 0xab498a11UL, 0x45e63f03UL,+    0x208183bbUL, 0x7691e0e3UL, 0x13f65c5bUL, 0xfd59e949UL, 0x983e55f1UL,+    0x2106826cUL, 0x44613ed4UL, 0xaace8bc6UL, 0xcfa9377eUL, 0x38417fd6UL,+    0x5d26c36eUL, 0xb389767cUL, 0xd6eecac4UL, 0x6fd61d59UL, 0x0ab1a1e1UL,+    0xe41e14f3UL, 0x8179a84bUL, 0xd769cb13UL, 0xb20e77abUL, 0x5ca1c2b9UL,+    0x39c67e01UL, 0x80fea99cUL, 0xe5991524UL, 0x0b36a036UL, 0x6e511c8eUL,+    0xa7166686UL, 0xc271da3eUL, 0x2cde6f2cUL, 0x49b9d394UL, 0xf0810409UL,+    0x95e6b8b1UL, 0x7b490da3UL, 0x1e2eb11bUL, 0x483ed243UL, 0x2d596efbUL,+    0xc3f6dbe9UL, 0xa6916751UL, 0x1fa9b0ccUL, 0x7ace0c74UL, 0x9461b966UL,+    0xf10605deUL+#endif+  }+};
+ cbits/deflate.h view
@@ -0,0 +1,342 @@+/* deflate.h -- internal compression state+ * Copyright (C) 1995-2010 Jean-loup Gailly+ * For conditions of distribution and use, see copyright notice in zlib.h+ */++/* WARNING: this file should *not* be used by applications. It is+   part of the implementation of the compression library and is+   subject to change. Applications should only use zlib.h.+ */++/* @(#) $Id$ */++#ifndef DEFLATE_H+#define DEFLATE_H++#include "zutil.h"++/* define NO_GZIP when compiling if you want to disable gzip header and+   trailer creation by deflate().  NO_GZIP would be used to avoid linking in+   the crc code when it is not needed.  For shared libraries, gzip encoding+   should be left enabled. */+#ifndef NO_GZIP+#  define GZIP+#endif++/* ===========================================================================+ * Internal compression state.+ */++#define LENGTH_CODES 29+/* number of length codes, not counting the special END_BLOCK code */++#define LITERALS  256+/* number of literal bytes 0..255 */++#define L_CODES (LITERALS+1+LENGTH_CODES)+/* number of Literal or Length codes, including the END_BLOCK code */++#define D_CODES   30+/* number of distance codes */++#define BL_CODES  19+/* number of codes used to transfer the bit lengths */++#define HEAP_SIZE (2*L_CODES+1)+/* maximum heap size */++#define MAX_BITS 15+/* All codes must not exceed MAX_BITS bits */++#define INIT_STATE    42+#define EXTRA_STATE   69+#define NAME_STATE    73+#define COMMENT_STATE 91+#define HCRC_STATE   103+#define BUSY_STATE   113+#define FINISH_STATE 666+/* Stream status */+++/* Data structure describing a single value and its code string. */+typedef struct ct_data_s {+    union {+        ush  freq;       /* frequency count */+        ush  code;       /* bit string */+    } fc;+    union {+        ush  dad;        /* father node in Huffman tree */+        ush  len;        /* length of bit string */+    } dl;+} FAR ct_data;++#define Freq fc.freq+#define Code fc.code+#define Dad  dl.dad+#define Len  dl.len++typedef struct static_tree_desc_s  static_tree_desc;++typedef struct tree_desc_s {+    ct_data *dyn_tree;           /* the dynamic tree */+    int     max_code;            /* largest code with non zero frequency */+    static_tree_desc *stat_desc; /* the corresponding static tree */+} FAR tree_desc;++typedef ush Pos;+typedef Pos FAR Posf;+typedef unsigned IPos;++/* A Pos is an index in the character window. We use short instead of int to+ * save space in the various tables. IPos is used only for parameter passing.+ */++typedef struct internal_state {+    z_streamp strm;      /* pointer back to this zlib stream */+    int   status;        /* as the name implies */+    Bytef *pending_buf;  /* output still pending */+    ulg   pending_buf_size; /* size of pending_buf */+    Bytef *pending_out;  /* next pending byte to output to the stream */+    uInt   pending;      /* nb of bytes in the pending buffer */+    int   wrap;          /* bit 0 true for zlib, bit 1 true for gzip */+    gz_headerp  gzhead;  /* gzip header information to write */+    uInt   gzindex;      /* where in extra, name, or comment */+    Byte  method;        /* STORED (for zip only) or DEFLATED */+    int   last_flush;    /* value of flush param for previous deflate call */++                /* used by deflate.c: */++    uInt  w_size;        /* LZ77 window size (32K by default) */+    uInt  w_bits;        /* log2(w_size)  (8..16) */+    uInt  w_mask;        /* w_size - 1 */++    Bytef *window;+    /* Sliding window. Input bytes are read into the second half of the window,+     * and move to the first half later to keep a dictionary of at least wSize+     * bytes. With this organization, matches are limited to a distance of+     * wSize-MAX_MATCH bytes, but this ensures that IO is always+     * performed with a length multiple of the block size. Also, it limits+     * the window size to 64K, which is quite useful on MSDOS.+     * To do: use the user input buffer as sliding window.+     */++    ulg window_size;+    /* Actual size of window: 2*wSize, except when the user input buffer+     * is directly used as sliding window.+     */++    Posf *prev;+    /* Link to older string with same hash index. To limit the size of this+     * array to 64K, this link is maintained only for the last 32K strings.+     * An index in this array is thus a window index modulo 32K.+     */++    Posf *head; /* Heads of the hash chains or NIL. */++    uInt  ins_h;          /* hash index of string to be inserted */+    uInt  hash_size;      /* number of elements in hash table */+    uInt  hash_bits;      /* log2(hash_size) */+    uInt  hash_mask;      /* hash_size-1 */++    uInt  hash_shift;+    /* Number of bits by which ins_h must be shifted at each input+     * step. It must be such that after MIN_MATCH steps, the oldest+     * byte no longer takes part in the hash key, that is:+     *   hash_shift * MIN_MATCH >= hash_bits+     */++    long block_start;+    /* Window position at the beginning of the current output block. Gets+     * negative when the window is moved backwards.+     */++    uInt match_length;           /* length of best match */+    IPos prev_match;             /* previous match */+    int match_available;         /* set if previous match exists */+    uInt strstart;               /* start of string to insert */+    uInt match_start;            /* start of matching string */+    uInt lookahead;              /* number of valid bytes ahead in window */++    uInt prev_length;+    /* Length of the best match at previous step. Matches not greater than this+     * are discarded. This is used in the lazy match evaluation.+     */++    uInt max_chain_length;+    /* To speed up deflation, hash chains are never searched beyond this+     * length.  A higher limit improves compression ratio but degrades the+     * speed.+     */++    uInt max_lazy_match;+    /* Attempt to find a better match only when the current match is strictly+     * smaller than this value. This mechanism is used only for compression+     * levels >= 4.+     */+#   define max_insert_length  max_lazy_match+    /* Insert new strings in the hash table only if the match length is not+     * greater than this length. This saves time but degrades compression.+     * max_insert_length is used only for compression levels <= 3.+     */++    int level;    /* compression level (1..9) */+    int strategy; /* favor or force Huffman coding*/++    uInt good_match;+    /* Use a faster search when the previous match is longer than this */++    int nice_match; /* Stop searching when current match exceeds this */++                /* used by trees.c: */+    /* Didn't use ct_data typedef below to supress compiler warning */+    struct ct_data_s dyn_ltree[HEAP_SIZE];   /* literal and length tree */+    struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */+    struct ct_data_s bl_tree[2*BL_CODES+1];  /* Huffman tree for bit lengths */++    struct tree_desc_s l_desc;               /* desc. for literal tree */+    struct tree_desc_s d_desc;               /* desc. for distance tree */+    struct tree_desc_s bl_desc;              /* desc. for bit length tree */++    ush bl_count[MAX_BITS+1];+    /* number of codes at each bit length for an optimal tree */++    int heap[2*L_CODES+1];      /* heap used to build the Huffman trees */+    int heap_len;               /* number of elements in the heap */+    int heap_max;               /* element of largest frequency */+    /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.+     * The same heap array is used to build all trees.+     */++    uch depth[2*L_CODES+1];+    /* Depth of each subtree used as tie breaker for trees of equal frequency+     */++    uchf *l_buf;          /* buffer for literals or lengths */++    uInt  lit_bufsize;+    /* Size of match buffer for literals/lengths.  There are 4 reasons for+     * limiting lit_bufsize to 64K:+     *   - frequencies can be kept in 16 bit counters+     *   - if compression is not successful for the first block, all input+     *     data is still in the window so we can still emit a stored block even+     *     when input comes from standard input.  (This can also be done for+     *     all blocks if lit_bufsize is not greater than 32K.)+     *   - if compression is not successful for a file smaller than 64K, we can+     *     even emit a stored file instead of a stored block (saving 5 bytes).+     *     This is applicable only for zip (not gzip or zlib).+     *   - creating new Huffman trees less frequently may not provide fast+     *     adaptation to changes in the input data statistics. (Take for+     *     example a binary file with poorly compressible code followed by+     *     a highly compressible string table.) Smaller buffer sizes give+     *     fast adaptation but have of course the overhead of transmitting+     *     trees more frequently.+     *   - I can't count above 4+     */++    uInt last_lit;      /* running index in l_buf */++    ushf *d_buf;+    /* Buffer for distances. To simplify the code, d_buf and l_buf have+     * the same number of elements. To use different lengths, an extra flag+     * array would be necessary.+     */++    ulg opt_len;        /* bit length of current block with optimal trees */+    ulg static_len;     /* bit length of current block with static trees */+    uInt matches;       /* number of string matches in current block */+    int last_eob_len;   /* bit length of EOB code for last block */++#ifdef DEBUG+    ulg compressed_len; /* total bit length of compressed file mod 2^32 */+    ulg bits_sent;      /* bit length of compressed data sent mod 2^32 */+#endif++    ush bi_buf;+    /* Output buffer. bits are inserted starting at the bottom (least+     * significant bits).+     */+    int bi_valid;+    /* Number of valid bits in bi_buf.  All bits above the last valid bit+     * are always zero.+     */++    ulg high_water;+    /* High water mark offset in window for initialized bytes -- bytes above+     * this are set to zero in order to avoid memory check warnings when+     * longest match routines access bytes past the input.  This is then+     * updated to the new high water mark.+     */++} FAR deflate_state;++/* Output a byte on the stream.+ * IN assertion: there is enough room in pending_buf.+ */+#define put_byte(s, c) {s->pending_buf[s->pending++] = (c);}+++#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1)+/* Minimum amount of lookahead, except at the end of the input file.+ * See deflate.c for comments about the MIN_MATCH+1.+ */++#define MAX_DIST(s)  ((s)->w_size-MIN_LOOKAHEAD)+/* In order to simplify the code, particularly on 16 bit machines, match+ * distances are limited to MAX_DIST instead of WSIZE.+ */++#define WIN_INIT MAX_MATCH+/* Number of bytes after end of data in window to initialize in order to avoid+   memory checker errors from longest match routines */++        /* in trees.c */+void ZLIB_INTERNAL _tr_init OF((deflate_state *s));+int ZLIB_INTERNAL _tr_tally OF((deflate_state *s, unsigned dist, unsigned lc));+void ZLIB_INTERNAL _tr_flush_block OF((deflate_state *s, charf *buf,+                        ulg stored_len, int last));+void ZLIB_INTERNAL _tr_align OF((deflate_state *s));+void ZLIB_INTERNAL _tr_stored_block OF((deflate_state *s, charf *buf,+                        ulg stored_len, int last));++#define d_code(dist) \+   ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)])+/* Mapping from a distance to a distance code. dist is the distance - 1 and+ * must not have side effects. _dist_code[256] and _dist_code[257] are never+ * used.+ */++#ifndef DEBUG+/* Inline versions of _tr_tally for speed: */++#if defined(GEN_TREES_H) || !defined(STDC)+  extern uch ZLIB_INTERNAL _length_code[];+  extern uch ZLIB_INTERNAL _dist_code[];+#else+  extern const uch ZLIB_INTERNAL _length_code[];+  extern const uch ZLIB_INTERNAL _dist_code[];+#endif++# define _tr_tally_lit(s, c, flush) \+  { uch cc = (c); \+    s->d_buf[s->last_lit] = 0; \+    s->l_buf[s->last_lit++] = cc; \+    s->dyn_ltree[cc].Freq++; \+    flush = (s->last_lit == s->lit_bufsize-1); \+   }+# define _tr_tally_dist(s, distance, length, flush) \+  { uch len = (length); \+    ush dist = (distance); \+    s->d_buf[s->last_lit] = dist; \+    s->l_buf[s->last_lit++] = len; \+    dist--; \+    s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \+    s->dyn_dtree[d_code(dist)].Freq++; \+    flush = (s->last_lit == s->lit_bufsize-1); \+  }+#else+# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c)+# define _tr_tally_dist(s, distance, length, flush) \+              flush = _tr_tally(s, distance, length)+#endif++#endif /* DEFLATE_H */
+ cbits/inffast.h view
@@ -0,0 +1,11 @@+/* inffast.h -- header to use inffast.c+ * Copyright (C) 1995-2003, 2010 Mark Adler+ * For conditions of distribution and use, see copyright notice in zlib.h+ */++/* WARNING: this file should *not* be used by applications. It is+   part of the implementation of the compression library and is+   subject to change. Applications should only use zlib.h.+ */++void ZLIB_INTERNAL inflate_fast OF((z_streamp strm, unsigned start));
+ cbits/inffixed.h view
@@ -0,0 +1,94 @@+    /* inffixed.h -- table for decoding fixed codes+     * Generated automatically by makefixed().+     */++    /* WARNING: this file should *not* be used by applications. It+       is part of the implementation of the compression library and+       is subject to change. Applications should only use zlib.h.+     */++    static const code lenfix[512] = {+        {96,7,0},{0,8,80},{0,8,16},{20,8,115},{18,7,31},{0,8,112},{0,8,48},+        {0,9,192},{16,7,10},{0,8,96},{0,8,32},{0,9,160},{0,8,0},{0,8,128},+        {0,8,64},{0,9,224},{16,7,6},{0,8,88},{0,8,24},{0,9,144},{19,7,59},+        {0,8,120},{0,8,56},{0,9,208},{17,7,17},{0,8,104},{0,8,40},{0,9,176},+        {0,8,8},{0,8,136},{0,8,72},{0,9,240},{16,7,4},{0,8,84},{0,8,20},+        {21,8,227},{19,7,43},{0,8,116},{0,8,52},{0,9,200},{17,7,13},{0,8,100},+        {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232},{16,7,8},+        {0,8,92},{0,8,28},{0,9,152},{20,7,83},{0,8,124},{0,8,60},{0,9,216},+        {18,7,23},{0,8,108},{0,8,44},{0,9,184},{0,8,12},{0,8,140},{0,8,76},+        {0,9,248},{16,7,3},{0,8,82},{0,8,18},{21,8,163},{19,7,35},{0,8,114},+        {0,8,50},{0,9,196},{17,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2},+        {0,8,130},{0,8,66},{0,9,228},{16,7,7},{0,8,90},{0,8,26},{0,9,148},+        {20,7,67},{0,8,122},{0,8,58},{0,9,212},{18,7,19},{0,8,106},{0,8,42},+        {0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244},{16,7,5},{0,8,86},+        {0,8,22},{64,8,0},{19,7,51},{0,8,118},{0,8,54},{0,9,204},{17,7,15},+        {0,8,102},{0,8,38},{0,9,172},{0,8,6},{0,8,134},{0,8,70},{0,9,236},+        {16,7,9},{0,8,94},{0,8,30},{0,9,156},{20,7,99},{0,8,126},{0,8,62},+        {0,9,220},{18,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142},+        {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{21,8,131},{18,7,31},+        {0,8,113},{0,8,49},{0,9,194},{16,7,10},{0,8,97},{0,8,33},{0,9,162},+        {0,8,1},{0,8,129},{0,8,65},{0,9,226},{16,7,6},{0,8,89},{0,8,25},+        {0,9,146},{19,7,59},{0,8,121},{0,8,57},{0,9,210},{17,7,17},{0,8,105},+        {0,8,41},{0,9,178},{0,8,9},{0,8,137},{0,8,73},{0,9,242},{16,7,4},+        {0,8,85},{0,8,21},{16,8,258},{19,7,43},{0,8,117},{0,8,53},{0,9,202},+        {17,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133},{0,8,69},+        {0,9,234},{16,7,8},{0,8,93},{0,8,29},{0,9,154},{20,7,83},{0,8,125},+        {0,8,61},{0,9,218},{18,7,23},{0,8,109},{0,8,45},{0,9,186},{0,8,13},+        {0,8,141},{0,8,77},{0,9,250},{16,7,3},{0,8,83},{0,8,19},{21,8,195},+        {19,7,35},{0,8,115},{0,8,51},{0,9,198},{17,7,11},{0,8,99},{0,8,35},+        {0,9,166},{0,8,3},{0,8,131},{0,8,67},{0,9,230},{16,7,7},{0,8,91},+        {0,8,27},{0,9,150},{20,7,67},{0,8,123},{0,8,59},{0,9,214},{18,7,19},+        {0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139},{0,8,75},{0,9,246},+        {16,7,5},{0,8,87},{0,8,23},{64,8,0},{19,7,51},{0,8,119},{0,8,55},+        {0,9,206},{17,7,15},{0,8,103},{0,8,39},{0,9,174},{0,8,7},{0,8,135},+        {0,8,71},{0,9,238},{16,7,9},{0,8,95},{0,8,31},{0,9,158},{20,7,99},+        {0,8,127},{0,8,63},{0,9,222},{18,7,27},{0,8,111},{0,8,47},{0,9,190},+        {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80},{0,8,16},+        {20,8,115},{18,7,31},{0,8,112},{0,8,48},{0,9,193},{16,7,10},{0,8,96},+        {0,8,32},{0,9,161},{0,8,0},{0,8,128},{0,8,64},{0,9,225},{16,7,6},+        {0,8,88},{0,8,24},{0,9,145},{19,7,59},{0,8,120},{0,8,56},{0,9,209},+        {17,7,17},{0,8,104},{0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72},+        {0,9,241},{16,7,4},{0,8,84},{0,8,20},{21,8,227},{19,7,43},{0,8,116},+        {0,8,52},{0,9,201},{17,7,13},{0,8,100},{0,8,36},{0,9,169},{0,8,4},+        {0,8,132},{0,8,68},{0,9,233},{16,7,8},{0,8,92},{0,8,28},{0,9,153},+        {20,7,83},{0,8,124},{0,8,60},{0,9,217},{18,7,23},{0,8,108},{0,8,44},+        {0,9,185},{0,8,12},{0,8,140},{0,8,76},{0,9,249},{16,7,3},{0,8,82},+        {0,8,18},{21,8,163},{19,7,35},{0,8,114},{0,8,50},{0,9,197},{17,7,11},+        {0,8,98},{0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229},+        {16,7,7},{0,8,90},{0,8,26},{0,9,149},{20,7,67},{0,8,122},{0,8,58},+        {0,9,213},{18,7,19},{0,8,106},{0,8,42},{0,9,181},{0,8,10},{0,8,138},+        {0,8,74},{0,9,245},{16,7,5},{0,8,86},{0,8,22},{64,8,0},{19,7,51},+        {0,8,118},{0,8,54},{0,9,205},{17,7,15},{0,8,102},{0,8,38},{0,9,173},+        {0,8,6},{0,8,134},{0,8,70},{0,9,237},{16,7,9},{0,8,94},{0,8,30},+        {0,9,157},{20,7,99},{0,8,126},{0,8,62},{0,9,221},{18,7,27},{0,8,110},+        {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253},{96,7,0},+        {0,8,81},{0,8,17},{21,8,131},{18,7,31},{0,8,113},{0,8,49},{0,9,195},+        {16,7,10},{0,8,97},{0,8,33},{0,9,163},{0,8,1},{0,8,129},{0,8,65},+        {0,9,227},{16,7,6},{0,8,89},{0,8,25},{0,9,147},{19,7,59},{0,8,121},+        {0,8,57},{0,9,211},{17,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9},+        {0,8,137},{0,8,73},{0,9,243},{16,7,4},{0,8,85},{0,8,21},{16,8,258},+        {19,7,43},{0,8,117},{0,8,53},{0,9,203},{17,7,13},{0,8,101},{0,8,37},+        {0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235},{16,7,8},{0,8,93},+        {0,8,29},{0,9,155},{20,7,83},{0,8,125},{0,8,61},{0,9,219},{18,7,23},+        {0,8,109},{0,8,45},{0,9,187},{0,8,13},{0,8,141},{0,8,77},{0,9,251},+        {16,7,3},{0,8,83},{0,8,19},{21,8,195},{19,7,35},{0,8,115},{0,8,51},+        {0,9,199},{17,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131},+        {0,8,67},{0,9,231},{16,7,7},{0,8,91},{0,8,27},{0,9,151},{20,7,67},+        {0,8,123},{0,8,59},{0,9,215},{18,7,19},{0,8,107},{0,8,43},{0,9,183},+        {0,8,11},{0,8,139},{0,8,75},{0,9,247},{16,7,5},{0,8,87},{0,8,23},+        {64,8,0},{19,7,51},{0,8,119},{0,8,55},{0,9,207},{17,7,15},{0,8,103},+        {0,8,39},{0,9,175},{0,8,7},{0,8,135},{0,8,71},{0,9,239},{16,7,9},+        {0,8,95},{0,8,31},{0,9,159},{20,7,99},{0,8,127},{0,8,63},{0,9,223},+        {18,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143},{0,8,79},+        {0,9,255}+    };++    static const code distfix[32] = {+        {16,5,1},{23,5,257},{19,5,17},{27,5,4097},{17,5,5},{25,5,1025},+        {21,5,65},{29,5,16385},{16,5,3},{24,5,513},{20,5,33},{28,5,8193},+        {18,5,9},{26,5,2049},{22,5,129},{64,5,0},{16,5,2},{23,5,385},+        {19,5,25},{27,5,6145},{17,5,7},{25,5,1537},{21,5,97},{29,5,24577},+        {16,5,4},{24,5,769},{20,5,49},{28,5,12289},{18,5,13},{26,5,3073},+        {22,5,193},{64,5,0}+    };
+ cbits/inflate.h view
@@ -0,0 +1,122 @@+/* inflate.h -- internal inflate state definition+ * Copyright (C) 1995-2009 Mark Adler+ * For conditions of distribution and use, see copyright notice in zlib.h+ */++/* WARNING: this file should *not* be used by applications. It is+   part of the implementation of the compression library and is+   subject to change. Applications should only use zlib.h.+ */++/* define NO_GZIP when compiling if you want to disable gzip header and+   trailer decoding by inflate().  NO_GZIP would be used to avoid linking in+   the crc code when it is not needed.  For shared libraries, gzip decoding+   should be left enabled. */+#ifndef NO_GZIP+#  define GUNZIP+#endif++/* Possible inflate modes between inflate() calls */+typedef enum {+    HEAD,       /* i: waiting for magic header */+    FLAGS,      /* i: waiting for method and flags (gzip) */+    TIME,       /* i: waiting for modification time (gzip) */+    OS,         /* i: waiting for extra flags and operating system (gzip) */+    EXLEN,      /* i: waiting for extra length (gzip) */+    EXTRA,      /* i: waiting for extra bytes (gzip) */+    NAME,       /* i: waiting for end of file name (gzip) */+    COMMENT,    /* i: waiting for end of comment (gzip) */+    HCRC,       /* i: waiting for header crc (gzip) */+    DICTID,     /* i: waiting for dictionary check value */+    DICT,       /* waiting for inflateSetDictionary() call */+        TYPE,       /* i: waiting for type bits, including last-flag bit */+        TYPEDO,     /* i: same, but skip check to exit inflate on new block */+        STORED,     /* i: waiting for stored size (length and complement) */+        COPY_,      /* i/o: same as COPY below, but only first time in */+        COPY,       /* i/o: waiting for input or output to copy stored block */+        TABLE,      /* i: waiting for dynamic block table lengths */+        LENLENS,    /* i: waiting for code length code lengths */+        CODELENS,   /* i: waiting for length/lit and distance code lengths */+            LEN_,       /* i: same as LEN below, but only first time in */+            LEN,        /* i: waiting for length/lit/eob code */+            LENEXT,     /* i: waiting for length extra bits */+            DIST,       /* i: waiting for distance code */+            DISTEXT,    /* i: waiting for distance extra bits */+            MATCH,      /* o: waiting for output space to copy string */+            LIT,        /* o: waiting for output space to write literal */+    CHECK,      /* i: waiting for 32-bit check value */+    LENGTH,     /* i: waiting for 32-bit length (gzip) */+    DONE,       /* finished check, done -- remain here until reset */+    BAD,        /* got a data error -- remain here until reset */+    MEM,        /* got an inflate() memory error -- remain here until reset */+    SYNC        /* looking for synchronization bytes to restart inflate() */+} inflate_mode;++/*+    State transitions between above modes -++    (most modes can go to BAD or MEM on error -- not shown for clarity)++    Process header:+        HEAD -> (gzip) or (zlib) or (raw)+        (gzip) -> FLAGS -> TIME -> OS -> EXLEN -> EXTRA -> NAME -> COMMENT ->+                  HCRC -> TYPE+        (zlib) -> DICTID or TYPE+        DICTID -> DICT -> TYPE+        (raw) -> TYPEDO+    Read deflate blocks:+            TYPE -> TYPEDO -> STORED or TABLE or LEN_ or CHECK+            STORED -> COPY_ -> COPY -> TYPE+            TABLE -> LENLENS -> CODELENS -> LEN_+            LEN_ -> LEN+    Read deflate codes in fixed or dynamic block:+                LEN -> LENEXT or LIT or TYPE+                LENEXT -> DIST -> DISTEXT -> MATCH -> LEN+                LIT -> LEN+    Process trailer:+        CHECK -> LENGTH -> DONE+ */++/* state maintained between inflate() calls.  Approximately 10K bytes. */+struct inflate_state {+    inflate_mode mode;          /* current inflate mode */+    int last;                   /* true if processing last block */+    int wrap;                   /* bit 0 true for zlib, bit 1 true for gzip */+    int havedict;               /* true if dictionary provided */+    int flags;                  /* gzip header method and flags (0 if zlib) */+    unsigned dmax;              /* zlib header max distance (INFLATE_STRICT) */+    unsigned long check;        /* protected copy of check value */+    unsigned long total;        /* protected copy of output count */+    gz_headerp head;            /* where to save gzip header information */+        /* sliding window */+    unsigned wbits;             /* log base 2 of requested window size */+    unsigned wsize;             /* window size or zero if not using window */+    unsigned whave;             /* valid bytes in the window */+    unsigned wnext;             /* window write index */+    unsigned char FAR *window;  /* allocated sliding window, if needed */+        /* bit accumulator */+    unsigned long hold;         /* input bit accumulator */+    unsigned bits;              /* number of bits in "in" */+        /* for string and stored block copying */+    unsigned length;            /* literal or length of data to copy */+    unsigned offset;            /* distance back to copy string from */+        /* for table and code decoding */+    unsigned extra;             /* extra bits needed */+        /* fixed and dynamic code tables */+    code const FAR *lencode;    /* starting table for length/literal codes */+    code const FAR *distcode;   /* starting table for distance codes */+    unsigned lenbits;           /* index bits for lencode */+    unsigned distbits;          /* index bits for distcode */+        /* dynamic table building */+    unsigned ncode;             /* number of code length code lengths */+    unsigned nlen;              /* number of length code lengths */+    unsigned ndist;             /* number of distance code lengths */+    unsigned have;              /* number of code lengths in lens[] */+    code FAR *next;             /* next available space in codes[] */+    unsigned short lens[320];   /* temporary storage for code lengths */+    unsigned short work[288];   /* work area for code table building */+    code codes[ENOUGH];         /* space for code tables */+    int sane;                   /* if false, allow invalid distance too far */+    int back;                   /* bits back of last unprocessed length/lit */+    unsigned was;               /* initial length of match */+};
+ cbits/inftrees.h view
@@ -0,0 +1,62 @@+/* inftrees.h -- header to use inftrees.c+ * Copyright (C) 1995-2005, 2010 Mark Adler+ * For conditions of distribution and use, see copyright notice in zlib.h+ */++/* WARNING: this file should *not* be used by applications. It is+   part of the implementation of the compression library and is+   subject to change. Applications should only use zlib.h.+ */++/* Structure for decoding tables.  Each entry provides either the+   information needed to do the operation requested by the code that+   indexed that table entry, or it provides a pointer to another+   table that indexes more bits of the code.  op indicates whether+   the entry is a pointer to another table, a literal, a length or+   distance, an end-of-block, or an invalid code.  For a table+   pointer, the low four bits of op is the number of index bits of+   that table.  For a length or distance, the low four bits of op+   is the number of extra bits to get after the code.  bits is+   the number of bits in this code or part of the code to drop off+   of the bit buffer.  val is the actual byte to output in the case+   of a literal, the base length or distance, or the offset from+   the current table to the next table.  Each entry is four bytes. */+typedef struct {+    unsigned char op;           /* operation, extra bits, table bits */+    unsigned char bits;         /* bits in this part of the code */+    unsigned short val;         /* offset in table or code value */+} code;++/* op values as set by inflate_table():+    00000000 - literal+    0000tttt - table link, tttt != 0 is the number of table index bits+    0001eeee - length or distance, eeee is the number of extra bits+    01100000 - end of block+    01000000 - invalid code+ */++/* Maximum size of the dynamic table.  The maximum number of code structures is+   1444, which is the sum of 852 for literal/length codes and 592 for distance+   codes.  These values were found by exhaustive searches using the program+   examples/enough.c found in the zlib distribtution.  The arguments to that+   program are the number of symbols, the initial root table size, and the+   maximum bit length of a code.  "enough 286 9 15" for literal/length codes+   returns returns 852, and "enough 30 6 15" for distance codes returns 592.+   The initial root table size (9 or 6) is found in the fifth argument of the+   inflate_table() calls in inflate.c and infback.c.  If the root table size is+   changed, then these maximum sizes would be need to be recalculated and+   updated. */+#define ENOUGH_LENS 852+#define ENOUGH_DISTS 592+#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS)++/* Type of code to build for inflate_table() */+typedef enum {+    CODES,+    LENS,+    DISTS+} codetype;++int ZLIB_INTERNAL inflate_table OF((codetype type, unsigned short FAR *lens,+                             unsigned codes, code FAR * FAR *table,+                             unsigned FAR *bits, unsigned short FAR *work));
+ cbits/initWinSock.c view
@@ -0,0 +1,63 @@+#include "HsNet.h"+#include "HsFFI.h"++#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__)++static int winsock_inited = 0;+static int winsock_uninited = 0;++/* Initialising WinSock... */+int+initWinSock ()+{+  WORD wVersionRequested;+  WSADATA wsaData;  +  int err;+#ifdef __HUGS__+  int optval = SO_SYNCHRONOUS_NONALERT;+#endif++  if (!winsock_inited) {+    wVersionRequested = MAKEWORD( 1, 1 );++    err = WSAStartup ( wVersionRequested, &wsaData );+    +    if ( err != 0 ) {+       return err;+    }++    if ( LOBYTE( wsaData.wVersion ) != 1 ||+       HIBYTE( wsaData.wVersion ) != 1 ) {+      WSACleanup();+      return (-1);+    }+#ifdef __HUGS__+    /* By default, socket() creates sockets in overlapped mode+     * (so that async I/O is possible). The CRT can only handle+     * non-overlapped sockets, so turn off overlap mode here.+     */+    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,+	       &optval, sizeof(optval));+#endif++    winsock_inited = 1;+  }+  return 0;+}++static void+shutdownHandler(void)+{+  WSACleanup();+}++void+shutdownWinSock()+{+    if (!winsock_uninited) {+	atexit(shutdownHandler);+	winsock_uninited = 1;+    }+}++#endif
+ cbits/trees.h view
@@ -0,0 +1,128 @@+/* header created automatically with -DGEN_TREES_H */++local const ct_data static_ltree[L_CODES+2] = {+{{ 12},{  8}}, {{140},{  8}}, {{ 76},{  8}}, {{204},{  8}}, {{ 44},{  8}},+{{172},{  8}}, {{108},{  8}}, {{236},{  8}}, {{ 28},{  8}}, {{156},{  8}},+{{ 92},{  8}}, {{220},{  8}}, {{ 60},{  8}}, {{188},{  8}}, {{124},{  8}},+{{252},{  8}}, {{  2},{  8}}, {{130},{  8}}, {{ 66},{  8}}, {{194},{  8}},+{{ 34},{  8}}, {{162},{  8}}, {{ 98},{  8}}, {{226},{  8}}, {{ 18},{  8}},+{{146},{  8}}, {{ 82},{  8}}, {{210},{  8}}, {{ 50},{  8}}, {{178},{  8}},+{{114},{  8}}, {{242},{  8}}, {{ 10},{  8}}, {{138},{  8}}, {{ 74},{  8}},+{{202},{  8}}, {{ 42},{  8}}, {{170},{  8}}, {{106},{  8}}, {{234},{  8}},+{{ 26},{  8}}, {{154},{  8}}, {{ 90},{  8}}, {{218},{  8}}, {{ 58},{  8}},+{{186},{  8}}, {{122},{  8}}, {{250},{  8}}, {{  6},{  8}}, {{134},{  8}},+{{ 70},{  8}}, {{198},{  8}}, {{ 38},{  8}}, {{166},{  8}}, {{102},{  8}},+{{230},{  8}}, {{ 22},{  8}}, {{150},{  8}}, {{ 86},{  8}}, {{214},{  8}},+{{ 54},{  8}}, {{182},{  8}}, {{118},{  8}}, {{246},{  8}}, {{ 14},{  8}},+{{142},{  8}}, {{ 78},{  8}}, {{206},{  8}}, {{ 46},{  8}}, {{174},{  8}},+{{110},{  8}}, {{238},{  8}}, {{ 30},{  8}}, {{158},{  8}}, {{ 94},{  8}},+{{222},{  8}}, {{ 62},{  8}}, {{190},{  8}}, {{126},{  8}}, {{254},{  8}},+{{  1},{  8}}, {{129},{  8}}, {{ 65},{  8}}, {{193},{  8}}, {{ 33},{  8}},+{{161},{  8}}, {{ 97},{  8}}, {{225},{  8}}, {{ 17},{  8}}, {{145},{  8}},+{{ 81},{  8}}, {{209},{  8}}, {{ 49},{  8}}, {{177},{  8}}, {{113},{  8}},+{{241},{  8}}, {{  9},{  8}}, {{137},{  8}}, {{ 73},{  8}}, {{201},{  8}},+{{ 41},{  8}}, {{169},{  8}}, {{105},{  8}}, {{233},{  8}}, {{ 25},{  8}},+{{153},{  8}}, {{ 89},{  8}}, {{217},{  8}}, {{ 57},{  8}}, {{185},{  8}},+{{121},{  8}}, {{249},{  8}}, {{  5},{  8}}, {{133},{  8}}, {{ 69},{  8}},+{{197},{  8}}, {{ 37},{  8}}, {{165},{  8}}, {{101},{  8}}, {{229},{  8}},+{{ 21},{  8}}, {{149},{  8}}, {{ 85},{  8}}, {{213},{  8}}, {{ 53},{  8}},+{{181},{  8}}, {{117},{  8}}, {{245},{  8}}, {{ 13},{  8}}, {{141},{  8}},+{{ 77},{  8}}, {{205},{  8}}, {{ 45},{  8}}, {{173},{  8}}, {{109},{  8}},+{{237},{  8}}, {{ 29},{  8}}, {{157},{  8}}, {{ 93},{  8}}, {{221},{  8}},+{{ 61},{  8}}, {{189},{  8}}, {{125},{  8}}, {{253},{  8}}, {{ 19},{  9}},+{{275},{  9}}, {{147},{  9}}, {{403},{  9}}, {{ 83},{  9}}, {{339},{  9}},+{{211},{  9}}, {{467},{  9}}, {{ 51},{  9}}, {{307},{  9}}, {{179},{  9}},+{{435},{  9}}, {{115},{  9}}, {{371},{  9}}, {{243},{  9}}, {{499},{  9}},+{{ 11},{  9}}, {{267},{  9}}, {{139},{  9}}, {{395},{  9}}, {{ 75},{  9}},+{{331},{  9}}, {{203},{  9}}, {{459},{  9}}, {{ 43},{  9}}, {{299},{  9}},+{{171},{  9}}, {{427},{  9}}, {{107},{  9}}, {{363},{  9}}, {{235},{  9}},+{{491},{  9}}, {{ 27},{  9}}, {{283},{  9}}, {{155},{  9}}, {{411},{  9}},+{{ 91},{  9}}, {{347},{  9}}, {{219},{  9}}, {{475},{  9}}, {{ 59},{  9}},+{{315},{  9}}, {{187},{  9}}, {{443},{  9}}, {{123},{  9}}, {{379},{  9}},+{{251},{  9}}, {{507},{  9}}, {{  7},{  9}}, {{263},{  9}}, {{135},{  9}},+{{391},{  9}}, {{ 71},{  9}}, {{327},{  9}}, {{199},{  9}}, {{455},{  9}},+{{ 39},{  9}}, {{295},{  9}}, {{167},{  9}}, {{423},{  9}}, {{103},{  9}},+{{359},{  9}}, {{231},{  9}}, {{487},{  9}}, {{ 23},{  9}}, {{279},{  9}},+{{151},{  9}}, {{407},{  9}}, {{ 87},{  9}}, {{343},{  9}}, {{215},{  9}},+{{471},{  9}}, {{ 55},{  9}}, {{311},{  9}}, {{183},{  9}}, {{439},{  9}},+{{119},{  9}}, {{375},{  9}}, {{247},{  9}}, {{503},{  9}}, {{ 15},{  9}},+{{271},{  9}}, {{143},{  9}}, {{399},{  9}}, {{ 79},{  9}}, {{335},{  9}},+{{207},{  9}}, {{463},{  9}}, {{ 47},{  9}}, {{303},{  9}}, {{175},{  9}},+{{431},{  9}}, {{111},{  9}}, {{367},{  9}}, {{239},{  9}}, {{495},{  9}},+{{ 31},{  9}}, {{287},{  9}}, {{159},{  9}}, {{415},{  9}}, {{ 95},{  9}},+{{351},{  9}}, {{223},{  9}}, {{479},{  9}}, {{ 63},{  9}}, {{319},{  9}},+{{191},{  9}}, {{447},{  9}}, {{127},{  9}}, {{383},{  9}}, {{255},{  9}},+{{511},{  9}}, {{  0},{  7}}, {{ 64},{  7}}, {{ 32},{  7}}, {{ 96},{  7}},+{{ 16},{  7}}, {{ 80},{  7}}, {{ 48},{  7}}, {{112},{  7}}, {{  8},{  7}},+{{ 72},{  7}}, {{ 40},{  7}}, {{104},{  7}}, {{ 24},{  7}}, {{ 88},{  7}},+{{ 56},{  7}}, {{120},{  7}}, {{  4},{  7}}, {{ 68},{  7}}, {{ 36},{  7}},+{{100},{  7}}, {{ 20},{  7}}, {{ 84},{  7}}, {{ 52},{  7}}, {{116},{  7}},+{{  3},{  8}}, {{131},{  8}}, {{ 67},{  8}}, {{195},{  8}}, {{ 35},{  8}},+{{163},{  8}}, {{ 99},{  8}}, {{227},{  8}}+};++local const ct_data static_dtree[D_CODES] = {+{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}},+{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}},+{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}},+{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}},+{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}},+{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}}+};++const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {+ 0,  1,  2,  3,  4,  4,  5,  5,  6,  6,  6,  6,  7,  7,  7,  7,  8,  8,  8,  8,+ 8,  8,  8,  8,  9,  9,  9,  9,  9,  9,  9,  9, 10, 10, 10, 10, 10, 10, 10, 10,+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,  0,  0, 16, 17,+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29+};++const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {+ 0,  1,  2,  3,  4,  5,  6,  7,  8,  8,  9,  9, 10, 10, 11, 11, 12, 12, 12, 12,+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28+};++local const int base_length[LENGTH_CODES] = {+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,+64, 80, 96, 112, 128, 160, 192, 224, 0+};++local const int base_dist[D_CODES] = {+    0,     1,     2,     3,     4,     6,     8,    12,    16,    24,+   32,    48,    64,    96,   128,   192,   256,   384,   512,   768,+ 1024,  1536,  2048,  3072,  4096,  6144,  8192, 12288, 16384, 24576+};+
+ cbits/winSockErr.c view
@@ -0,0 +1,76 @@+#include "HsNet.h"+#include "HsFFI.h"++#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__)+#include <stdio.h>++/* to the end */++const char*+getWSErrorDescr(int err)+{+  static char  otherErrMsg[256];++  switch (err) {+  case WSAEINTR:  return "Interrupted function call (WSAEINTR)";+  case WSAEBADF:  return "bad socket descriptor (WSAEBADF)";+  case WSAEACCES: return "Permission denied (WSAEACCESS)";+  case WSAEFAULT: return "Bad address (WSAEFAULT)";+  case WSAEINVAL: return "Invalid argument (WSAEINVAL)";+  case WSAEMFILE: return "Too many open files (WSAEMFILE)";+  case WSAEWOULDBLOCK:  return "Resource temporarily unavailable (WSAEWOULDBLOCK)";+  case WSAEINPROGRESS:  return "Operation now in progress (WSAEINPROGRESS)";+  case WSAEALREADY:     return "Operation already in progress (WSAEALREADY)";+  case WSAENOTSOCK:     return "Socket operation on non-socket (WSAENOTSOCK)";+  case WSAEDESTADDRREQ: return "Destination address required (WSAEDESTADDRREQ)";+  case WSAEMSGSIZE:    	return "Message too long (WSAEMSGSIZE)";+  case WSAEPROTOTYPE:   return "Protocol wrong type for socket (WSAEPROTOTYPE)";+  case WSAENOPROTOOPT:  return "Bad protocol option (WSAENOPROTOOPT)";+  case WSAEPROTONOSUPPORT: return "Protocol not supported (WSAEPROTONOSUPPORT)";+  case WSAESOCKTNOSUPPORT: return "Socket type not supported (WSAESOCKTNOSUPPORT)";+  case WSAEOPNOTSUPP:      return "Operation not supported (WSAEOPNOTSUPP)";+  case WSAEPFNOSUPPORT:    return "Protocol family not supported (WSAEPFNOSUPPORT)";+  case WSAEAFNOSUPPORT:    return "Address family not supported by protocol family (WSAEAFNOSUPPORT)";+  case WSAEADDRINUSE:      return "Address already in use (WSAEADDRINUSE)";+  case WSAEADDRNOTAVAIL:   return "Cannot assign requested address (WSAEADDRNOTAVAIL)";+  case WSAENETDOWN:        return "Network is down (WSAENETDOWN)";+  case WSAENETUNREACH:     return "Network is unreachable (WSAENETUNREACH)";+  case WSAENETRESET:       return "Network dropped connection on reset (WSAENETRESET)";+  case WSAECONNABORTED:    return "Software caused connection abort (WSAECONNABORTED)";+  case WSAECONNRESET:      return "Connection reset by peer (WSAECONNRESET)";+  case WSAENOBUFS:         return "No buffer space available (WSAENOBUFS)";+  case WSAEISCONN:         return "Socket is already connected (WSAEISCONN)";+  case WSAENOTCONN:        return "Socket is not connected (WSAENOTCONN)";+  case WSAESHUTDOWN:       return "Cannot send after socket shutdown (WSAESHUTDOWN)";+  case WSAETOOMANYREFS:    return "Too many references (WSAETOOMANYREFS)";+  case WSAETIMEDOUT:       return "Connection timed out (WSAETIMEDOUT)";+  case WSAECONNREFUSED:    return "Connection refused (WSAECONNREFUSED)";+  case WSAELOOP:           return "Too many levels of symbolic links (WSAELOOP)";+  case WSAENAMETOOLONG:    return "Filename too long (WSAENAMETOOLONG)";+  case WSAEHOSTDOWN:       return "Host is down (WSAEHOSTDOWN)";+  case WSAEHOSTUNREACH:    return "Host is unreachable (WSAEHOSTUNREACH)";+  case WSAENOTEMPTY:       return "Resource not empty (WSAENOTEMPTY)";+  case WSAEPROCLIM:        return "Too many processes (WSAEPROCLIM)";+  case WSAEUSERS:          return "Too many users (WSAEUSERS)";+  case WSAEDQUOT:          return "Disk quota exceeded (WSAEDQUOT)";+  case WSAESTALE:          return "Stale NFS file handle (WSAESTALE)";+  case WSAEREMOTE:         return "Too many levels of remote in path (WSAEREMOTE)";+  case WSAEDISCON:         return "Graceful shutdown in progress (WSAEDISCON)";+  case WSASYSNOTREADY:     return "Network subsystem is unavailable (WSASYSNOTREADY)";+  case WSAVERNOTSUPPORTED: return "Winsock.dll version out of range (WSAVERNOTSUPPORTED)";+  case WSANOTINITIALISED:  return "Successful WSAStartup not yet performed (WSANOTINITIALISED)";+#ifdef WSATYPE_NOT_FOUND+  case WSATYPE_NOT_FOUND:  return "Class type not found (WSATYPE_NOT_FOUND)";+#endif+  case WSAHOST_NOT_FOUND:  return "Host not found (WSAHOST_NOT_FOUND)";+  case WSATRY_AGAIN:       return "Nonauthoritative host not found (WSATRY_AGAIN)";+  case WSANO_RECOVERY:     return "This is a nonrecoverable error (WSANO_RECOVERY)";+  case WSANO_DATA:         return "Valid name, no data record of requested type (WSANO_DATA)";+  default:+    sprintf(otherErrMsg, "Unknown WinSock error: %u", err);+    return otherErrMsg;+  }+}++#endif+
+ cbits/zutil.h view
@@ -0,0 +1,274 @@+/* zutil.h -- internal interface and configuration of the compression library+ * Copyright (C) 1995-2010 Jean-loup Gailly.+ * For conditions of distribution and use, see copyright notice in zlib.h+ */++/* WARNING: this file should *not* be used by applications. It is+   part of the implementation of the compression library and is+   subject to change. Applications should only use zlib.h.+ */++/* @(#) $Id$ */++#ifndef ZUTIL_H+#define ZUTIL_H++#if ((__GNUC__-0) * 10 + __GNUC_MINOR__-0 >= 33) && !defined(NO_VIZ)+#  define ZLIB_INTERNAL __attribute__((visibility ("hidden")))+#else+#  define ZLIB_INTERNAL+#endif++#include "zlib.h"++#ifdef STDC+#  if !(defined(_WIN32_WCE) && defined(_MSC_VER))+#    include <stddef.h>+#  endif+#  include <string.h>+#  include <stdlib.h>+#endif++#ifndef local+#  define local static+#endif+/* compile with -Dlocal if your debugger can't find static symbols */++typedef unsigned char  uch;+typedef uch FAR uchf;+typedef unsigned short ush;+typedef ush FAR ushf;+typedef unsigned long  ulg;++extern const char * const z_errmsg[10]; /* indexed by 2-zlib_error */+/* (size given to avoid silly warnings with Visual C++) */++#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)]++#define ERR_RETURN(strm,err) \+  return (strm->msg = (char*)ERR_MSG(err), (err))+/* To be used only when the state is known to be valid */++        /* common constants */++#ifndef DEF_WBITS+#  define DEF_WBITS MAX_WBITS+#endif+/* default windowBits for decompression. MAX_WBITS is for compression only */++#if MAX_MEM_LEVEL >= 8+#  define DEF_MEM_LEVEL 8+#else+#  define DEF_MEM_LEVEL  MAX_MEM_LEVEL+#endif+/* default memLevel */++#define STORED_BLOCK 0+#define STATIC_TREES 1+#define DYN_TREES    2+/* The three kinds of block type */++#define MIN_MATCH  3+#define MAX_MATCH  258+/* The minimum and maximum match lengths */++#define PRESET_DICT 0x20 /* preset dictionary flag in zlib header */++        /* target dependencies */++#if defined(MSDOS) || (defined(WINDOWS) && !defined(WIN32))+#  define OS_CODE  0x00+#  if defined(__TURBOC__) || defined(__BORLANDC__)+#    if (__STDC__ == 1) && (defined(__LARGE__) || defined(__COMPACT__))+       /* Allow compilation with ANSI keywords only enabled */+       void _Cdecl farfree( void *block );+       void *_Cdecl farmalloc( unsigned long nbytes );+#    else+#      include <alloc.h>+#    endif+#  else /* MSC or DJGPP */+#    include <malloc.h>+#  endif+#endif++#ifdef AMIGA+#  define OS_CODE  0x01+#endif++#if defined(VAXC) || defined(VMS)+#  define OS_CODE  0x02+#  define F_OPEN(name, mode) \+     fopen((name), (mode), "mbc=60", "ctx=stm", "rfm=fix", "mrs=512")+#endif++#if defined(ATARI) || defined(atarist)+#  define OS_CODE  0x05+#endif++#ifdef OS2+#  define OS_CODE  0x06+#  ifdef M_I86+#    include <malloc.h>+#  endif+#endif++#if defined(MACOS) || defined(TARGET_OS_MAC)+#  define OS_CODE  0x07+#  if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os+#    include <unix.h> /* for fdopen */+#  else+#    ifndef fdopen+#      define fdopen(fd,mode) NULL /* No fdopen() */+#    endif+#  endif+#endif++#ifdef TOPS20+#  define OS_CODE  0x0a+#endif++#ifdef WIN32+#  ifndef __CYGWIN__  /* Cygwin is Unix, not Win32 */+#    define OS_CODE  0x0b+#  endif+#endif++#ifdef __50SERIES /* Prime/PRIMOS */+#  define OS_CODE  0x0f+#endif++#if defined(_BEOS_) || defined(RISCOS)+#  define fdopen(fd,mode) NULL /* No fdopen() */+#endif++#if (defined(_MSC_VER) && (_MSC_VER > 600)) && !defined __INTERIX+#  if defined(_WIN32_WCE)+#    define fdopen(fd,mode) NULL /* No fdopen() */+#    ifndef _PTRDIFF_T_DEFINED+       typedef int ptrdiff_t;+#      define _PTRDIFF_T_DEFINED+#    endif+#  else+#    define fdopen(fd,type)  _fdopen(fd,type)+#  endif+#endif++#if defined(__BORLANDC__)+  #pragma warn -8004+  #pragma warn -8008+  #pragma warn -8066+#endif++/* provide prototypes for these when building zlib without LFS */+#if !defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0+    ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));+    ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));+#endif++        /* common defaults */++#ifndef OS_CODE+#  define OS_CODE  0x03  /* assume Unix */+#endif++#ifndef F_OPEN+#  define F_OPEN(name, mode) fopen((name), (mode))+#endif++         /* functions */++#if defined(STDC99) || (defined(__TURBOC__) && __TURBOC__ >= 0x550)+#  ifndef HAVE_VSNPRINTF+#    define HAVE_VSNPRINTF+#  endif+#endif+#if defined(__CYGWIN__)+#  ifndef HAVE_VSNPRINTF+#    define HAVE_VSNPRINTF+#  endif+#endif+#ifndef HAVE_VSNPRINTF+#  ifdef MSDOS+     /* vsnprintf may exist on some MS-DOS compilers (DJGPP?),+        but for now we just assume it doesn't. */+#    define NO_vsnprintf+#  endif+#  ifdef __TURBOC__+#    define NO_vsnprintf+#  endif+#  ifdef WIN32+     /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */+#    if !defined(vsnprintf) && !defined(NO_vsnprintf)+#      if !defined(_MSC_VER) || ( defined(_MSC_VER) && _MSC_VER < 1500 )+#         define vsnprintf _vsnprintf+#      endif+#    endif+#  endif+#  ifdef __SASC+#    define NO_vsnprintf+#  endif+#endif+#ifdef VMS+#  define NO_vsnprintf+#endif++#if defined(pyr)+#  define NO_MEMCPY+#endif+#if defined(SMALL_MEDIUM) && !defined(_MSC_VER) && !defined(__SC__)+ /* Use our own functions for small and medium model with MSC <= 5.0.+  * You may have to use the same strategy for Borland C (untested).+  * The __SC__ check is for Symantec.+  */+#  define NO_MEMCPY+#endif+#if defined(STDC) && !defined(HAVE_MEMCPY) && !defined(NO_MEMCPY)+#  define HAVE_MEMCPY+#endif+#ifdef HAVE_MEMCPY+#  ifdef SMALL_MEDIUM /* MSDOS small or medium model */+#    define zmemcpy _fmemcpy+#    define zmemcmp _fmemcmp+#    define zmemzero(dest, len) _fmemset(dest, 0, len)+#  else+#    define zmemcpy memcpy+#    define zmemcmp memcmp+#    define zmemzero(dest, len) memset(dest, 0, len)+#  endif+#else+   void ZLIB_INTERNAL zmemcpy OF((Bytef* dest, const Bytef* source, uInt len));+   int ZLIB_INTERNAL zmemcmp OF((const Bytef* s1, const Bytef* s2, uInt len));+   void ZLIB_INTERNAL zmemzero OF((Bytef* dest, uInt len));+#endif++/* Diagnostic functions */+#ifdef DEBUG+#  include <stdio.h>+   extern int ZLIB_INTERNAL z_verbose;+   extern void ZLIB_INTERNAL z_error OF((char *m));+#  define Assert(cond,msg) {if(!(cond)) z_error(msg);}+#  define Trace(x) {if (z_verbose>=0) fprintf x ;}+#  define Tracev(x) {if (z_verbose>0) fprintf x ;}+#  define Tracevv(x) {if (z_verbose>1) fprintf x ;}+#  define Tracec(c,x) {if (z_verbose>0 && (c)) fprintf x ;}+#  define Tracecv(c,x) {if (z_verbose>1 && (c)) fprintf x ;}+#else+#  define Assert(cond,msg)+#  define Trace(x)+#  define Tracev(x)+#  define Tracevv(x)+#  define Tracec(c,x)+#  define Tracecv(c,x)+#endif+++voidpf ZLIB_INTERNAL zcalloc OF((voidpf opaque, unsigned items,+                        unsigned size));+void ZLIB_INTERNAL zcfree  OF((voidpf opaque, voidpf ptr));++#define ZALLOC(strm, items, size) \+           (*((strm)->zalloc))((strm)->opaque, (items), (size))+#define ZFREE(strm, addr)  (*((strm)->zfree))((strm)->opaque, (voidpf)(addr))+#define TRY_FREE(s, p) {if (p) ZFREE(s, p);}++#endif /* ZUTIL_H */
+ config.guess view
@@ -0,0 +1,1497 @@+#! /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 Free Software Foundation, Inc.++timestamp='2006-02-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+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 ;;+	    *) 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 powerppc-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.*:*)+	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:*:[45])+	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/[-(].*//'` ;;+	    *)+		echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+	esac+	exit ;;+    i*:CYGWIN*:*)+	echo ${UNAME_MACHINE}-pc-cygwin+	exit ;;+    i*:MINGW*:*)+	echo ${UNAME_MACHINE}-pc-mingw32+	exit ;;+    i*:MSYS_NT-*:*:*)+	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 ;;+    x86:Interix*:[345]*)+	echo i586-pc-interix${UNAME_RELEASE}+	exit ;;+    EM64T:Interix*:[345]*)+	echo x86_64-unknown-interix${UNAME_RELEASE}+	exit ;;+    [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:*:*)+	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 ;;+    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(__sun)+	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 ;;+    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://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.guess+and+  http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.sub++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,1608 @@+#! /bin/sh+# Configuration validation subroutine script.+#   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,+#   2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.++timestamp='2006-02-23'++# 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+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 \+	| bfin \+	| c4x | clipper \+	| d10v | d30v | dlx | dsp16xx \+	| fr30 | frv \+	| h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \+	| i370 | i860 | i960 | ia64 \+	| ip2k | iq2000 \+	| m32r | m32rle | m68000 | m68k | m88k | maxq | mb | microblaze | 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 \+	| mn10200 | mn10300 \+	| mt \+	| msp430 \+	| nios | nios2 \+	| ns16k | ns32k \+	| or32 \+	| pdp10 | pdp11 | pj | pjl \+	| powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \+	| pyramid \+	| sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \+	| sh64 | sh64le \+	| sparc | sparc64 | sparc64b | sparc86x | sparclet | sparclite \+	| sparcv8 | sparcv9 | sparcv9b \+	| strongarm \+	| tahoe | thumb | tic4x | tic80 | tron \+	| v850 | v850e \+	| we32k \+	| x86 | xscale | xscalee[bl] | xstormy16 | xtensa \+	| z8k)+		basic_machine=$basic_machine-unknown+		;;+	m32c)+		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-* \+	| bfin-* | bs2000-* \+	| c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \+	| clipper-* | craynv-* | cydra-* \+	| d10v-* | d30v-* | dlx-* \+	| elxsi-* \+	| f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \+	| h8300-* | h8500-* \+	| hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \+	| i*86-* | i860-* | i960-* | ia64-* \+	| ip2k-* | iq2000-* \+	| 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-* | shbe-* \+	| shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \+	| sparc-* | sparc64-* | sparc64b-* | sparc86x-* | sparclet-* \+	| sparclite-* \+	| sparcv8-* | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \+	| tahoe-* | thumb-* \+	| tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \+	| tron-* \+	| v850-* | v850e-* | vax-* \+	| we32k-* \+	| x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \+	| xstormy16-* | xtensa-* \+	| ymp-* \+	| z8k-*)+		;;+	m32c-*)+		;;+	# 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+		;;+	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+		;;+	cr16c)+		basic_machine=cr16c-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+		;;+	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+		;;+	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+		;;+	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+		;;+	sei)+		basic_machine=mips-sei+		os=-seiux+		;;+	sequent)+		basic_machine=i386-sequent+		;;+	sh)+		basic_machine=sh-hitachi+		os=-hms+		;;+	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+		;;+	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)+		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*)+	# 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+	*-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+		;;+	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,6297 @@+#! /bin/sh+# Guess values for system-dependent variables and create Makefiles.+# Generated by GNU Autoconf 2.61 for Haskell network package 2.3.0.11.+#+# 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 network package'+PACKAGE_TARNAME='network'+PACKAGE_VERSION='2.3.0.11'+PACKAGE_STRING='Haskell network package 2.3.0.11'+PACKAGE_BUGREPORT='libraries@haskell.org'++ac_unique_file="include/HsNet.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+build+build_cpu+build_vendor+build_os+host+host_cpu+host_vendor+host_os+CC+CFLAGS+LDFLAGS+CPPFLAGS+ac_ct_CC+EXEEXT+OBJEXT+CPP+GREP+EGREP+CALLCONV+EXTRA_CPPFLAGS+EXTRA_LIBS+EXTRA_SRCS+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 network package 2.3.0.11 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/network]+  --htmldir=DIR          html documentation [DOCDIR]+  --dvidir=DIR           dvi documentation [DOCDIR]+  --pdfdir=DIR           pdf documentation [DOCDIR]+  --psdir=DIR            ps documentation [DOCDIR]+_ACEOF++  cat <<\_ACEOF++System types:+  --build=BUILD     configure for building on BUILD [guessed]+  --host=HOST       cross-compile to build programs to run on HOST [BUILD]+_ACEOF+fi++if test -n "$ac_init_help"; then+  case $ac_init_help in+     short | recursive ) echo "Configuration of Haskell network package 2.3.0.11:";;+   esac+  cat <<\_ACEOF++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 network package configure 2.3.0.11+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 network package $as_me 2.3.0.11, 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++++ac_includes_default="$ac_includes_default+#ifdef HAVE_NETDB_H+# include <netdb.h>+#endif+#ifdef HAVE_WINSOCK2_H+# include <winsock2.h>+#endif+#ifdef HAVE_WS2TCPIP_H+# include <ws2tcpip.h>+// fix for MingW not defining IPV6_V6ONLY+# define IPV6_V6ONLY 27+#endif+#ifdef HAVE_WSPIAPI_H+# include <wspiapi.h>+#endif"++# Safety check: Ensure that we are in the correct source directory.+++ac_config_headers="$ac_config_headers include/HsNetworkConfig.h"+++ac_aux_dir=+for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do+  if test -f "$ac_dir/install-sh"; then+    ac_aux_dir=$ac_dir+    ac_install_sh="$ac_aux_dir/install-sh -c"+    break+  elif test -f "$ac_dir/install.sh"; then+    ac_aux_dir=$ac_dir+    ac_install_sh="$ac_aux_dir/install.sh -c"+    break+  elif test -f "$ac_dir/shtool"; then+    ac_aux_dir=$ac_dir+    ac_install_sh="$ac_aux_dir/shtool install -c"+    break+  fi+done+if test -z "$ac_aux_dir"; then+  { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5+echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;}+   { (exit 1); exit 1; }; }+fi++# These three variables are undocumented and unsupported,+# and are intended to be withdrawn in a future Autoconf release.+# They can cause serious problems if a builder's source tree is in a directory+# whose full name contains unusual characters.+ac_config_guess="$SHELL $ac_aux_dir/config.guess"  # Please don't use this var.+ac_config_sub="$SHELL $ac_aux_dir/config.sub"  # Please don't use this var.+ac_configure="$SHELL $ac_aux_dir/configure"  # Please don't use this var.+++# Make sure we can run config.sub.+$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||+  { { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5+echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;}+   { (exit 1); exit 1; }; }++{ echo "$as_me:$LINENO: checking build system type" >&5+echo $ECHO_N "checking build system type... $ECHO_C" >&6; }+if test "${ac_cv_build+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  ac_build_alias=$build_alias+test "x$ac_build_alias" = x &&+  ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`+test "x$ac_build_alias" = x &&+  { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5+echo "$as_me: error: cannot guess build type; you must specify one" >&2;}+   { (exit 1); exit 1; }; }+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||+  { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;}+   { (exit 1); exit 1; }; }++fi+{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5+echo "${ECHO_T}$ac_cv_build" >&6; }+case $ac_cv_build in+*-*-*) ;;+*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5+echo "$as_me: error: invalid value of canonical build" >&2;}+   { (exit 1); exit 1; }; };;+esac+build=$ac_cv_build+ac_save_IFS=$IFS; IFS='-'+set x $ac_cv_build+shift+build_cpu=$1+build_vendor=$2+shift; shift+# Remember, the first character of IFS is used to create $*,+# except with old shells:+build_os=$*+IFS=$ac_save_IFS+case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac+++{ echo "$as_me:$LINENO: checking host system type" >&5+echo $ECHO_N "checking host system type... $ECHO_C" >&6; }+if test "${ac_cv_host+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if test "x$host_alias" = x; then+  ac_cv_host=$ac_cv_build+else+  ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||+    { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;}+   { (exit 1); exit 1; }; }+fi++fi+{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5+echo "${ECHO_T}$ac_cv_host" >&6; }+case $ac_cv_host in+*-*-*) ;;+*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5+echo "$as_me: error: invalid value of canonical host" >&2;}+   { (exit 1); exit 1; }; };;+esac+host=$ac_cv_host+ac_save_IFS=$IFS; IFS='-'+set x $ac_cv_host+shift+host_cpu=$1+host_vendor=$2+shift; shift+# Remember, the first character of IFS is used to create $*,+# except with old shells:+host_os=$*+IFS=$ac_save_IFS+case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac+++++# 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++++{ 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+++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 -r 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 -r 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+++++++++++for ac_header in fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h wspiapi.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+++++++++for ac_header in arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.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+++++for ac_func in readlink symlink+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+++{ echo "$as_me:$LINENO: checking for struct msghdr.msg_control" >&5+echo $ECHO_N "checking for struct msghdr.msg_control... $ECHO_C" >&6; }+if test "${ac_cv_member_struct_msghdr_msg_control+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.  */+#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#if HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif++int+main ()+{+static struct msghdr ac_aggr;+if (ac_aggr.msg_control)+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_member_struct_msghdr_msg_control=yes+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_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#if HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif++int+main ()+{+static struct msghdr ac_aggr;+if (sizeof ac_aggr.msg_control)+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_member_struct_msghdr_msg_control=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_member_struct_msghdr_msg_control=no+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+{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_msghdr_msg_control" >&5+echo "${ECHO_T}$ac_cv_member_struct_msghdr_msg_control" >&6; }+if test $ac_cv_member_struct_msghdr_msg_control = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_STRUCT_MSGHDR_MSG_CONTROL 1+_ACEOF+++fi+{ echo "$as_me:$LINENO: checking for struct msghdr.msg_accrights" >&5+echo $ECHO_N "checking for struct msghdr.msg_accrights... $ECHO_C" >&6; }+if test "${ac_cv_member_struct_msghdr_msg_accrights+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.  */+#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#if HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif++int+main ()+{+static struct msghdr ac_aggr;+if (ac_aggr.msg_accrights)+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_member_struct_msghdr_msg_accrights=yes+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_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#if HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif++int+main ()+{+static struct msghdr ac_aggr;+if (sizeof ac_aggr.msg_accrights)+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_member_struct_msghdr_msg_accrights=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_member_struct_msghdr_msg_accrights=no+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+{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_msghdr_msg_accrights" >&5+echo "${ECHO_T}$ac_cv_member_struct_msghdr_msg_accrights" >&6; }+if test $ac_cv_member_struct_msghdr_msg_accrights = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS 1+_ACEOF+++fi+++{ echo "$as_me:$LINENO: checking for struct sockaddr.sa_len" >&5+echo $ECHO_N "checking for struct sockaddr.sa_len... $ECHO_C" >&6; }+if test "${ac_cv_member_struct_sockaddr_sa_len+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.  */+#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif++int+main ()+{+static struct sockaddr ac_aggr;+if (ac_aggr.sa_len)+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_member_struct_sockaddr_sa_len=yes+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_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif++int+main ()+{+static struct sockaddr ac_aggr;+if (sizeof ac_aggr.sa_len)+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_member_struct_sockaddr_sa_len=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_member_struct_sockaddr_sa_len=no+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+{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_sockaddr_sa_len" >&5+echo "${ECHO_T}$ac_cv_member_struct_sockaddr_sa_len" >&6; }+if test $ac_cv_member_struct_sockaddr_sa_len = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_STRUCT_SOCKADDR_SA_LEN 1+_ACEOF+++fi+++{ echo "$as_me:$LINENO: checking for in_addr_t in netinet/in.h" >&5+echo $ECHO_N "checking for in_addr_t in netinet/in.h... $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 <netinet/in.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "in_addr_t" >/dev/null 2>&1; then++cat >>confdefs.h <<\_ACEOF+#define HAVE_IN_ADDR_T 1+_ACEOF+ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+rm -f -r conftest*+++{ echo "$as_me:$LINENO: checking for SO_PEERCRED and struct ucred in sys/socket.h" >&5+echo $ECHO_N "checking for SO_PEERCRED and struct ucred in sys/socket.h... $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 <sys/types.h>+#include <sys/socket.h>+#ifndef SO_PEERCRED+# error no SO_PEERCRED+#endif+struct ucred u;+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_ucred=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_ucred=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+if test "x$ac_cv_ucred" = xno; then+    old_CFLAGS="$CFLAGS"+    CFLAGS="-D_GNU_SOURCE $CFLAGS"+    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>+#include <sys/socket.h>+#ifndef SO_PEERCRED+# error no SO_PEERCRED+#endif+struct ucred u;+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_ucred=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_ucred=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+    if test "x$ac_cv_ucred" = xyes; then+        EXTRA_CPPFLAGS=-D_GNU_SOURCE+    fi+else+    old_CFLAGS="$CFLAGS"+fi+if test "x$ac_cv_ucred" = xno; then+    CFLAGS="$old_CFLAGS"+    { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+else++cat >>confdefs.h <<\_ACEOF+#define HAVE_STRUCT_UCRED 1+_ACEOF++    { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+fi+++{ echo "$as_me:$LINENO: checking for _head_libws2_32_a in -lws2_32" >&5+echo $ECHO_N "checking for _head_libws2_32_a in -lws2_32... $ECHO_C" >&6; }+if test "${ac_cv_lib_ws2_32__head_libws2_32_a+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  ac_check_lib_save_LIBS=$LIBS+LIBS="-lws2_32  $LIBS"+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++/* Override any GCC internal prototype to avoid an error.+   Use char because int might match the return type of a GCC+   builtin and then its argument prototype would still apply.  */+#ifdef __cplusplus+extern "C"+#endif+char _head_libws2_32_a ();+int+main ()+{+return _head_libws2_32_a ();+  ;+  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+  ac_cv_lib_ws2_32__head_libws2_32_a=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_lib_ws2_32__head_libws2_32_a=no+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+      conftest$ac_exeext conftest.$ac_ext+LIBS=$ac_check_lib_save_LIBS+fi+{ echo "$as_me:$LINENO: result: $ac_cv_lib_ws2_32__head_libws2_32_a" >&5+echo "${ECHO_T}$ac_cv_lib_ws2_32__head_libws2_32_a" >&6; }+if test $ac_cv_lib_ws2_32__head_libws2_32_a = yes; then+  cat >>confdefs.h <<_ACEOF+#define HAVE_LIBWS2_32 1+_ACEOF++  LIBS="-lws2_32 $LIBS"++fi+++{ echo "$as_me:$LINENO: checking for getaddrinfo" >&5+echo $ECHO_N "checking for getaddrinfo... $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+int testme(){ getaddrinfo; }+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++cat >>confdefs.h <<\_ACEOF+#define HAVE_GETADDRINFO 1+_ACEOF+ ac_have_getaddrinfo=yes; { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	{ echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++if test "x$ac_have_getaddrinfo" = x; then+  old_CFLAGS="$CFLAGS"+  if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then+    CFLAGS="-DWINVER=0x0501 $CFLAGS"+    { echo "$as_me:$LINENO: checking for getaddrinfo if WINVER is 0x0501" >&5+echo $ECHO_N "checking for getaddrinfo if WINVER is 0x0501... $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+    int testme(){ getaddrinfo; }+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++cat >>confdefs.h <<\_ACEOF+#define HAVE_GETADDRINFO 1+_ACEOF++cat >>confdefs.h <<\_ACEOF+#define NEED_WINVER_XP 1+_ACEOF+ EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	CFLAGS="$old_CFLAGS"; { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  fi+fi+++for ac_func in gai_strerror+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+++{ echo "$as_me:$LINENO: checking whether AI_ADDRCONFIG is declared" >&5+echo $ECHO_N "checking whether AI_ADDRCONFIG is declared... $ECHO_C" >&6; }+if test "${ac_cv_have_decl_AI_ADDRCONFIG+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+int+main ()+{+#ifndef AI_ADDRCONFIG+  (void) AI_ADDRCONFIG;+#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_have_decl_AI_ADDRCONFIG=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_have_decl_AI_ADDRCONFIG=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_ADDRCONFIG" >&5+echo "${ECHO_T}$ac_cv_have_decl_AI_ADDRCONFIG" >&6; }+if test $ac_cv_have_decl_AI_ADDRCONFIG = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_ADDRCONFIG 1+_ACEOF+++else+  cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_ADDRCONFIG 0+_ACEOF+++fi+{ echo "$as_me:$LINENO: checking whether AI_ALL is declared" >&5+echo $ECHO_N "checking whether AI_ALL is declared... $ECHO_C" >&6; }+if test "${ac_cv_have_decl_AI_ALL+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+int+main ()+{+#ifndef AI_ALL+  (void) AI_ALL;+#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_have_decl_AI_ALL=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_have_decl_AI_ALL=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_ALL" >&5+echo "${ECHO_T}$ac_cv_have_decl_AI_ALL" >&6; }+if test $ac_cv_have_decl_AI_ALL = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_ALL 1+_ACEOF+++else+  cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_ALL 0+_ACEOF+++fi+{ echo "$as_me:$LINENO: checking whether AI_NUMERICSERV is declared" >&5+echo $ECHO_N "checking whether AI_NUMERICSERV is declared... $ECHO_C" >&6; }+if test "${ac_cv_have_decl_AI_NUMERICSERV+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+int+main ()+{+#ifndef AI_NUMERICSERV+  (void) AI_NUMERICSERV;+#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_have_decl_AI_NUMERICSERV=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_have_decl_AI_NUMERICSERV=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_NUMERICSERV" >&5+echo "${ECHO_T}$ac_cv_have_decl_AI_NUMERICSERV" >&6; }+if test $ac_cv_have_decl_AI_NUMERICSERV = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_NUMERICSERV 1+_ACEOF+++else+  cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_NUMERICSERV 0+_ACEOF+++fi+{ echo "$as_me:$LINENO: checking whether AI_V4MAPPED is declared" >&5+echo $ECHO_N "checking whether AI_V4MAPPED is declared... $ECHO_C" >&6; }+if test "${ac_cv_have_decl_AI_V4MAPPED+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+int+main ()+{+#ifndef AI_V4MAPPED+  (void) AI_V4MAPPED;+#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_have_decl_AI_V4MAPPED=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_have_decl_AI_V4MAPPED=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_V4MAPPED" >&5+echo "${ECHO_T}$ac_cv_have_decl_AI_V4MAPPED" >&6; }+if test $ac_cv_have_decl_AI_V4MAPPED = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_V4MAPPED 1+_ACEOF+++else+  cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_AI_V4MAPPED 0+_ACEOF+++fi++++{ echo "$as_me:$LINENO: checking whether IPV6_V6ONLY is declared" >&5+echo $ECHO_N "checking whether IPV6_V6ONLY is declared... $ECHO_C" >&6; }+if test "${ac_cv_have_decl_IPV6_V6ONLY+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+int+main ()+{+#ifndef IPV6_V6ONLY+  (void) IPV6_V6ONLY;+#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_have_decl_IPV6_V6ONLY=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_have_decl_IPV6_V6ONLY=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_IPV6_V6ONLY" >&5+echo "${ECHO_T}$ac_cv_have_decl_IPV6_V6ONLY" >&6; }+if test $ac_cv_have_decl_IPV6_V6ONLY = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_IPV6_V6ONLY 1+_ACEOF+++else+  cat >>confdefs.h <<_ACEOF+#define HAVE_DECL_IPV6_V6ONLY 0+_ACEOF+++fi++++{ echo "$as_me:$LINENO: checking for sendfile in sys/sendfile.h" >&5+echo $ECHO_N "checking for sendfile in sys/sendfile.h... $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 <sys/sendfile.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "sendfile" >/dev/null 2>&1; then++cat >>confdefs.h <<\_ACEOF+#define HAVE_LINUX_SENDFILE 1+_ACEOF+ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+rm -f -r conftest*+++{ echo "$as_me:$LINENO: checking for sendfile in sys/socket.h" >&5+echo $ECHO_N "checking for sendfile in sys/socket.h... $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 <sys/socket.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "sendfile" >/dev/null 2>&1; then++cat >>confdefs.h <<\_ACEOF+#define HAVE_BSD_SENDFILE 1+_ACEOF+ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+rm -f -r conftest*++++for ac_func in gethostent+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+++case "$host" in+*-mingw32)+	EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c"+	EXTRA_LIBS=ws2_32+	CALLCONV=stdcall ;;+*-solaris2*)+	EXTRA_SRCS="cbits/ancilData.c"+	EXTRA_LIBS="nsl, socket"+	CALLCONV=ccall ;;+*)+	EXTRA_SRCS="cbits/ancilData.c"+	EXTRA_LIBS=+	CALLCONV=ccall ;;+esac++++++ac_config_files="$ac_config_files network.buildinfo"+++cat >confcache <<\_ACEOF+# This file is a shell script that caches the results of configure+# tests run on this system so they can be shared between configure+# scripts and configure runs, see configure's option --config-cache.+# It is not useful on other systems.  If it contains results you don't+# want to keep, you may remove or edit it.+#+# config.status only pays attention to the cache file if you give it+# the --recheck option to rerun configure.+#+# `ac_cv_env_foo' variables (set or unset) will be overridden when+# loading this file, other *unset* `ac_cv_foo' will be assigned the+# following values.++_ACEOF++# The following way of writing the cache mishandles newlines in values,+# but we know of no workaround that is simple, portable, and efficient.+# So, we kill variables containing newlines.+# Ultrix sh set writes to stderr and can't be redirected directly,+# and sets the high bit in the cache file unless we assign to the vars.+(+  for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do+    eval ac_val=\$$ac_var+    case $ac_val in #(+    *${as_nl}*)+      case $ac_var in #(+      *_cv_*) { 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 network package $as_me 2.3.0.11, 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_files="$ac_config_files"+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+  --file=FILE[:TEMPLATE]+		   instantiate the configuration file FILE+  --header=FILE[:TEMPLATE]+		   instantiate the configuration header FILE++Configuration files:+$config_files++Configuration headers:+$config_headers++Report bugs to <bug-autoconf@gnu.org>."++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+ac_cs_version="\\+Haskell network package config.status 2.3.0.11+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=: ;;+  --file | --fil | --fi | --f )+    $ac_shift+    CONFIG_FILES="$CONFIG_FILES $ac_optarg"+    ac_need_defaults=false;;+  --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/HsNetworkConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsNetworkConfig.h" ;;+    "network.buildinfo") CONFIG_FILES="$CONFIG_FILES network.buildinfo" ;;++  *) { { 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_FILES+set}" = set || CONFIG_FILES=$config_files+  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; }+}++#+# Set up the sed scripts for CONFIG_FILES section.+#++# No need to generate the scripts if there are no CONFIG_FILES.+# This happens for instance when ./config.status config.h+if test -n "$CONFIG_FILES"; then++_ACEOF++++ac_delim='%!_!# '+for ac_last_try in false false false false false :; do+  cat >conf$$subs.sed <<_ACEOF+SHELL!$SHELL$ac_delim+PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim+PACKAGE_NAME!$PACKAGE_NAME$ac_delim+PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim+PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim+PACKAGE_STRING!$PACKAGE_STRING$ac_delim+PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim+exec_prefix!$exec_prefix$ac_delim+prefix!$prefix$ac_delim+program_transform_name!$program_transform_name$ac_delim+bindir!$bindir$ac_delim+sbindir!$sbindir$ac_delim+libexecdir!$libexecdir$ac_delim+datarootdir!$datarootdir$ac_delim+datadir!$datadir$ac_delim+sysconfdir!$sysconfdir$ac_delim+sharedstatedir!$sharedstatedir$ac_delim+localstatedir!$localstatedir$ac_delim+includedir!$includedir$ac_delim+oldincludedir!$oldincludedir$ac_delim+docdir!$docdir$ac_delim+infodir!$infodir$ac_delim+htmldir!$htmldir$ac_delim+dvidir!$dvidir$ac_delim+pdfdir!$pdfdir$ac_delim+psdir!$psdir$ac_delim+libdir!$libdir$ac_delim+localedir!$localedir$ac_delim+mandir!$mandir$ac_delim+DEFS!$DEFS$ac_delim+ECHO_C!$ECHO_C$ac_delim+ECHO_N!$ECHO_N$ac_delim+ECHO_T!$ECHO_T$ac_delim+LIBS!$LIBS$ac_delim+build_alias!$build_alias$ac_delim+host_alias!$host_alias$ac_delim+target_alias!$target_alias$ac_delim+build!$build$ac_delim+build_cpu!$build_cpu$ac_delim+build_vendor!$build_vendor$ac_delim+build_os!$build_os$ac_delim+host!$host$ac_delim+host_cpu!$host_cpu$ac_delim+host_vendor!$host_vendor$ac_delim+host_os!$host_os$ac_delim+CC!$CC$ac_delim+CFLAGS!$CFLAGS$ac_delim+LDFLAGS!$LDFLAGS$ac_delim+CPPFLAGS!$CPPFLAGS$ac_delim+ac_ct_CC!$ac_ct_CC$ac_delim+EXEEXT!$EXEEXT$ac_delim+OBJEXT!$OBJEXT$ac_delim+CPP!$CPP$ac_delim+GREP!$GREP$ac_delim+EGREP!$EGREP$ac_delim+CALLCONV!$CALLCONV$ac_delim+EXTRA_CPPFLAGS!$EXTRA_CPPFLAGS$ac_delim+EXTRA_LIBS!$EXTRA_LIBS$ac_delim+EXTRA_SRCS!$EXTRA_SRCS$ac_delim+LIBOBJS!$LIBOBJS$ac_delim+LTLIBOBJS!$LTLIBOBJS$ac_delim+_ACEOF++  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 61; then+    break+  elif $ac_last_try; then+    { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5+echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}+   { (exit 1); exit 1; }; }+  else+    ac_delim="$ac_delim!$ac_delim _$ac_delim!! "+  fi+done++ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`+if test -n "$ac_eof"; then+  ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`+  ac_eof=`expr $ac_eof + 1`+fi++cat >>$CONFIG_STATUS <<_ACEOF+cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end+_ACEOF+sed '+s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g+s/^/s,@/; s/!/@,|#_!!_#|/+:n+t n+s/'"$ac_delim"'$/,g/; t+s/$/\\/; p+N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n+' >>$CONFIG_STATUS <conf$$subs.sed+rm -f conf$$subs.sed+cat >>$CONFIG_STATUS <<_ACEOF+:end+s/|#_!!_#|//g+CEOF$ac_eof+_ACEOF+++# VPATH may cause trouble with some makes, so we remove $(srcdir),+# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and+# trailing colons and then remove the whole line if VPATH becomes empty+# (actually we leave an empty line to preserve line numbers).+if test "x$srcdir" = x.; then+  ac_vpsub='/^[	 ]*VPATH[	 ]*=/{+s/:*\$(srcdir):*/:/+s/:*\${srcdir}:*/:/+s/:*@srcdir@:*/:/+s/^\([^=]*=[	 ]*\):*/\1/+s/:*$//+s/^[^=]*=[	 ]*$//+}'+fi++cat >>$CONFIG_STATUS <<\_ACEOF+fi # test -n "$CONFIG_FILES"+++for ac_tag in  :F $CONFIG_FILES  :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+  :F)+  #+  # CONFIG_FILE+  #++_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+# If the template does not know about datarootdir, expand it.+# FIXME: This hack should be removed a few years after 2.60.+ac_datarootdir_hack=; ac_datarootdir_seen=++case `sed -n '/datarootdir/ {+  p+  q+}+/@datadir@/p+/@docdir@/p+/@infodir@/p+/@localedir@/p+/@mandir@/p+' $ac_file_inputs` in+*datarootdir*) ac_datarootdir_seen=yes;;+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)+  { echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5+echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}+_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+  ac_datarootdir_hack='+  s&@datadir@&$datadir&g+  s&@docdir@&$docdir&g+  s&@infodir@&$infodir&g+  s&@localedir@&$localedir&g+  s&@mandir@&$mandir&g+    s&\\\${datarootdir}&$datarootdir&g' ;;+esac+_ACEOF++# Neutralize VPATH when `$srcdir' = `.'.+# Shell code in configure.ac might set extrasub.+# FIXME: do we really want to maintain this feature?+cat >>$CONFIG_STATUS <<_ACEOF+  sed "$ac_vpsub+$extrasub+_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF+:t+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b+s&@configure_input@&$configure_input&;t t+s&@top_builddir@&$ac_top_builddir_sub&;t t+s&@srcdir@&$ac_srcdir&;t t+s&@abs_srcdir@&$ac_abs_srcdir&;t t+s&@top_srcdir@&$ac_top_srcdir&;t t+s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t+s&@builddir@&$ac_builddir&;t t+s&@abs_builddir@&$ac_abs_builddir&;t t+s&@abs_top_builddir@&$ac_abs_top_builddir&;t t+$ac_datarootdir_hack+" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out++test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&+  { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&+  { ac_out=`sed -n '/^[	 ]*datarootdir[	 ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&+  { echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'+which seems to be undefined.  Please make sure it is defined." >&5+echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'+which seems to be undefined.  Please make sure it is defined." >&2;}++  rm -f "$tmp/stdin"+  case $ac_file in+  -) cat "$tmp/out"; rm -f "$tmp/out";;+  *) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;+  esac+ ;;+  :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,176 @@+AC_INIT([Haskell network package], [2.3.0.11], [libraries@haskell.org], [network])++ac_includes_default="$ac_includes_default+#ifdef HAVE_NETDB_H+# include <netdb.h>+#endif+#ifdef HAVE_WINSOCK2_H+# include <winsock2.h>+#endif+#ifdef HAVE_WS2TCPIP_H+# include <ws2tcpip.h>+// fix for MingW not defining IPV6_V6ONLY+# define IPV6_V6ONLY 27+#endif+#ifdef HAVE_WSPIAPI_H+# include <wspiapi.h>+#endif"++# Safety check: Ensure that we are in the correct source directory.+AC_CONFIG_SRCDIR([include/HsNet.h])++AC_CONFIG_HEADERS([include/HsNetworkConfig.h])++AC_CANONICAL_HOST++AC_ARG_WITH([cc],+            [C compiler],+            [CC=$withval])+AC_PROG_CC()++AC_C_CONST++dnl ** check for specific header (.h) files that we are interested in+AC_CHECK_HEADERS([fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h wspiapi.h])+AC_CHECK_HEADERS([arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.h])++AC_CHECK_FUNCS([readlink symlink])++dnl ** check what fields struct msghdr contains+AC_CHECK_MEMBERS([struct msghdr.msg_control, struct msghdr.msg_accrights], [], [], [#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#if HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif])++dnl ** check if struct sockaddr contains sa_len+AC_CHECK_MEMBERS([struct sockaddr.sa_len], [], [], [#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#if HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif])++dnl --------------------------------------------------+dnl * test for in_addr_t+dnl --------------------------------------------------+AC_MSG_CHECKING(for in_addr_t in netinet/in.h)+AC_EGREP_HEADER(in_addr_t, netinet/in.h,+ [ AC_DEFINE([HAVE_IN_ADDR_T], [1], [Define to 1 if in_addr_t is available.]) AC_MSG_RESULT(yes) ],+ AC_MSG_RESULT(no))++dnl --------------------------------------------------+dnl * test for SO_PEERCRED and struct ucred+dnl --------------------------------------------------+AC_MSG_CHECKING(for SO_PEERCRED and struct ucred in sys/socket.h)+AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>+#include <sys/socket.h>+#ifndef SO_PEERCRED+# error no SO_PEERCRED+#endif+struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no)+if test "x$ac_cv_ucred" = xno; then+    old_CFLAGS="$CFLAGS"+    CFLAGS="-D_GNU_SOURCE $CFLAGS"+    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>+#include <sys/socket.h>+#ifndef SO_PEERCRED+# error no SO_PEERCRED+#endif+struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no)+    if test "x$ac_cv_ucred" = xyes; then+        EXTRA_CPPFLAGS=-D_GNU_SOURCE+    fi+else+    old_CFLAGS="$CFLAGS"+fi+if test "x$ac_cv_ucred" = xno; then+    CFLAGS="$old_CFLAGS"+    AC_MSG_RESULT(no)+else+    AC_DEFINE([HAVE_STRUCT_UCRED], [1], [Define to 1 if you have both SO_PEERCRED and struct ucred.])+    AC_MSG_RESULT(yes)+fi++dnl --------------------------------------------------+dnl * check for Windows networking libraries+dnl --------------------------------------------------+AC_CHECK_LIB(ws2_32, _head_libws2_32_a)++dnl --------------------------------------------------+dnl * test for getaddrinfo as proxy for IPv6 support+dnl --------------------------------------------------+AC_MSG_CHECKING(for getaddrinfo)+dnl Can't use AC_CHECK_FUNC here, because it doesn't do the right+dnl thing on Windows.+AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default+int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) ac_have_getaddrinfo=yes; AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)])++dnl Under mingw, we may need to set WINVER to 0x0501 to expose getaddrinfo.+if test "x$ac_have_getaddrinfo" = x; then+  old_CFLAGS="$CFLAGS"+  if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then+    CFLAGS="-DWINVER=0x0501 $CFLAGS"+    AC_MSG_CHECKING(for getaddrinfo if WINVER is 0x0501)+    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default+    int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) AC_DEFINE([NEED_WINVER_XP], [1], [Define to 1 if the `getaddrinfo' function needs WINVER set.]) EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; AC_MSG_RESULT(yes)],[CFLAGS="$old_CFLAGS"; AC_MSG_RESULT(no)])+  fi+fi++dnl Missing under mingw, sigh.+AC_CHECK_FUNCS(gai_strerror)++dnl -------------------------------------------------------+dnl * test for AI_* flags that not all implementations have+dnl -------------------------------------------------------+AC_CHECK_DECLS([AI_ADDRCONFIG, AI_ALL, AI_NUMERICSERV, AI_V4MAPPED])++dnl -------------------------------------------------------+dnl * test for IPV6_V6ONLY flags that not all implementations have+dnl -------------------------------------------------------+AC_CHECK_DECLS([IPV6_V6ONLY])++dnl --------------------------------------------------+dnl * test for Linux sendfile(2)+dnl --------------------------------------------------+AC_MSG_CHECKING(for sendfile in sys/sendfile.h)+AC_EGREP_HEADER(sendfile, sys/sendfile.h,+ [ AC_DEFINE([HAVE_LINUX_SENDFILE], [1], [Define to 1 if you have a Linux sendfile(2) implementation.]) AC_MSG_RESULT(yes) ],+ AC_MSG_RESULT(no))++dnl --------------------------------------------------+dnl * test for BSD sendfile(2)+dnl --------------------------------------------------+AC_MSG_CHECKING(for sendfile in sys/socket.h)+AC_EGREP_HEADER(sendfile, sys/socket.h,+ [ AC_DEFINE([HAVE_BSD_SENDFILE], [1], [Define to 1 if you have a BSDish sendfile(2) implementation.]) AC_MSG_RESULT(yes) ],+ AC_MSG_RESULT(no))++AC_CHECK_FUNCS(gethostent)++case "$host" in+*-mingw32)+	EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c"+	EXTRA_LIBS=ws2_32+	CALLCONV=stdcall ;;+*-solaris2*)+	EXTRA_SRCS="cbits/ancilData.c"+	EXTRA_LIBS="nsl, socket"+	CALLCONV=ccall ;;+*)+	EXTRA_SRCS="cbits/ancilData.c"+	EXTRA_LIBS=+	CALLCONV=ccall ;;+esac+AC_SUBST([CALLCONV])+AC_SUBST([EXTRA_CPPFLAGS])+AC_SUBST([EXTRA_LIBS])+AC_SUBST([EXTRA_SRCS])++AC_CONFIG_FILES([network.buildinfo])++AC_OUTPUT
+ include/HsNet.h view
@@ -0,0 +1,195 @@+/* -----------------------------------------------------------------------------+ *+ * Definitions for package `net' which are visible in Haskell land.+ *+ * ---------------------------------------------------------------------------*/++#ifndef HSNET_H+#define HSNET_H++#include "HsNetworkConfig.h"++#ifdef NEED_WINVER+# define WINVER 0x0501+#endif++/* ultra-evil... */+#undef PACKAGE_BUGREPORT+#undef PACKAGE_NAME+#undef PACKAGE_STRING+#undef PACKAGE_TARNAME+#undef PACKAGE_VERSION++#ifndef INLINE+# if defined(_MSC_VER)+#  define INLINE extern __inline+# elif defined(__GNUC__)+#  define INLINE extern inline+# else+#  define INLINE inline+# endif+#endif++#ifdef HAVE_GETADDRINFO+# define IPV6_SOCKET_SUPPORT 1+#else+# undef IPV6_SOCKET_SUPPORT+#endif++#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__)+#include <winsock2.h>+# ifdef HAVE_WS2TCPIP_H+#  include <ws2tcpip.h>+// fix for MingW not defining IPV6_V6ONLY+#  define IPV6_V6ONLY 27+# endif+# ifdef HAVE_WSPIAPI_H+#  include <wspiapi.h>+# endif++extern void  shutdownWinSock();+extern int   initWinSock ();+extern const char* getWSErrorDescr(int err);++# if !defined(__HUGS__)+extern void* newAcceptParams(int sock,+			     int sz,+			     void* sockaddr);+extern int   acceptNewSock(void* d);+extern int   acceptDoProc(void* param);+# endif++#else++#ifdef HAVE_LIMITS_H+# include <limits.h>+#endif+#ifdef HAVE_STDLIB_H+# include <stdlib.h>+#endif+#ifdef HAVE_UNISTD_H+#include <unistd.h>+#endif+#ifdef HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#ifdef HAVE_FCNTL_H+# include <fcntl.h>+#endif+#ifdef HAVE_SYS_UIO_H+# include <sys/uio.h>+#endif+#ifdef HAVE_SYS_SOCKET_H+# include <sys/socket.h>+#endif+#ifdef HAVE_NETINET_TCP_H+# include <netinet/tcp.h>+#endif+#ifdef HAVE_NETINET_IN_H+# include <netinet/in.h>+#endif+#ifdef HAVE_SYS_UN_H+# include <sys/un.h>+#endif+#ifdef HAVE_ARPA_INET_H+# include <arpa/inet.h>+#endif+#ifdef HAVE_NETDB_H+#include <netdb.h>+#endif++#ifdef HAVE_BSD_SENDFILE+#include <sys/uio.h>+#endif+#ifdef HAVE_LINUX_SENDFILE+#if !defined(__USE_FILE_OFFSET64)+#include <sys/sendfile.h>+#endif+#endif++extern int+sendFd(int sock, int outfd);++extern int+recvFd(int sock);++/* The next two are scheduled for deletion */+extern int+sendAncillary(int sock,+	      int level,+	      int type,+	      int flags,+	      void* data,+	      int len);++extern int+recvAncillary(int  sock,+	      int* pLevel,+	      int* pType,+	      int  flags,+	      void** pData,+	      int* pLen);++#endif /* HAVE_WINSOCK2_H && !__CYGWIN */++INLINE char *+my_inet_ntoa(+#if defined(HAVE_WINSOCK2_H)+             u_long addr+#elif defined(HAVE_IN_ADDR_T)+             in_addr_t addr+#elif defined(HAVE_INTTYPES_H)+             u_int32_t addr+#else+             unsigned long addr+#endif+	    )+{ +    struct in_addr a;+    a.s_addr = addr;+    return inet_ntoa(a);+}++#ifdef HAVE_GETADDRINFO+INLINE int+hsnet_getnameinfo(const struct sockaddr* a,socklen_t b, char* c,+# if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__)+                  DWORD d, char* e, DWORD f, int g)+# else+                  socklen_t d, char* e, socklen_t f, int g)+# endif+{+  return getnameinfo(a,b,c,d,e,f,g);+}++INLINE int+hsnet_getaddrinfo(const char *hostname, const char *servname,+		  const struct addrinfo *hints, struct addrinfo **res)+{+    return getaddrinfo(hostname, servname, hints, res);+}++INLINE void+hsnet_freeaddrinfo(struct addrinfo *ai)+{+    freeaddrinfo(ai);+}+#endif++#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+# define WITH_WINSOCK  1+#endif++#if !defined(mingw32_HOST_OS) && !defined(_WIN32)+# define DOMAIN_SOCKET_SUPPORT 1+#endif++#if !defined(CALLCONV)+# if defined(WITH_WINSOCK)+#  define CALLCONV stdcall+# else+#  define CALLCONV ccall+# endif+#endif++#endif /* HSNET_H */
+ include/HsNetworkConfig.h.in view
@@ -0,0 +1,147 @@+/* include/HsNetworkConfig.h.in.  Generated from configure.ac by autoheader.  */++/* Define to 1 if you have the <arpa/inet.h> header file. */+#undef HAVE_ARPA_INET_H++/* Define to 1 if you have a BSDish sendfile(2) implementation. */+#undef HAVE_BSD_SENDFILE++/* Define to 1 if you have the declaration of `AI_ADDRCONFIG', and to 0 if you+   don't. */+#undef HAVE_DECL_AI_ADDRCONFIG++/* Define to 1 if you have the declaration of `AI_ALL', and to 0 if you don't.+   */+#undef HAVE_DECL_AI_ALL++/* Define to 1 if you have the declaration of `AI_NUMERICSERV', and to 0 if+   you don't. */+#undef HAVE_DECL_AI_NUMERICSERV++/* Define to 1 if you have the declaration of `AI_V4MAPPED', and to 0 if you+   don't. */+#undef HAVE_DECL_AI_V4MAPPED++/* Define to 1 if you have the declaration of `IPV6_V6ONLY', and to 0 if you+   don't. */+#undef HAVE_DECL_IPV6_V6ONLY++/* Define to 1 if you have the <fcntl.h> header file. */+#undef HAVE_FCNTL_H++/* Define to 1 if you have the `gai_strerror' function. */+#undef HAVE_GAI_STRERROR++/* Define to 1 if you have the `getaddrinfo' function. */+#undef HAVE_GETADDRINFO++/* Define to 1 if you have the `gethostent' function. */+#undef HAVE_GETHOSTENT++/* Define to 1 if you have the <inttypes.h> header file. */+#undef HAVE_INTTYPES_H++/* Define to 1 if in_addr_t is available. */+#undef HAVE_IN_ADDR_T++/* Define to 1 if you have the `ws2_32' library (-lws2_32). */+#undef HAVE_LIBWS2_32++/* Define to 1 if you have the <limits.h> header file. */+#undef HAVE_LIMITS_H++/* Define to 1 if you have a Linux sendfile(2) implementation. */+#undef HAVE_LINUX_SENDFILE++/* Define to 1 if you have the <memory.h> header file. */+#undef HAVE_MEMORY_H++/* Define to 1 if you have the <netdb.h> header file. */+#undef HAVE_NETDB_H++/* Define to 1 if you have the <netinet/in.h> header file. */+#undef HAVE_NETINET_IN_H++/* Define to 1 if you have the <netinet/tcp.h> header file. */+#undef HAVE_NETINET_TCP_H++/* Define to 1 if you have the `readlink' function. */+#undef HAVE_READLINK++/* Define to 1 if you have the <stdint.h> header file. */+#undef HAVE_STDINT_H++/* Define to 1 if you have the <stdlib.h> header file. */+#undef HAVE_STDLIB_H++/* Define to 1 if you have the <strings.h> header file. */+#undef HAVE_STRINGS_H++/* Define to 1 if you have the <string.h> header file. */+#undef HAVE_STRING_H++/* Define to 1 if `msg_accrights' is member of `struct msghdr'. */+#undef HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS++/* Define to 1 if `msg_control' is member of `struct msghdr'. */+#undef HAVE_STRUCT_MSGHDR_MSG_CONTROL++/* Define to 1 if `sa_len' is member of `struct sockaddr'. */+#undef HAVE_STRUCT_SOCKADDR_SA_LEN++/* Define to 1 if you have both SO_PEERCRED and struct ucred. */+#undef HAVE_STRUCT_UCRED++/* Define to 1 if you have the `symlink' function. */+#undef HAVE_SYMLINK++/* Define to 1 if you have the <sys/socket.h> header file. */+#undef HAVE_SYS_SOCKET_H++/* Define to 1 if you have the <sys/stat.h> header file. */+#undef HAVE_SYS_STAT_H++/* Define to 1 if you have the <sys/types.h> header file. */+#undef HAVE_SYS_TYPES_H++/* Define to 1 if you have the <sys/uio.h> header file. */+#undef HAVE_SYS_UIO_H++/* Define to 1 if you have the <sys/un.h> header file. */+#undef HAVE_SYS_UN_H++/* Define to 1 if you have the <unistd.h> header file. */+#undef HAVE_UNISTD_H++/* Define to 1 if you have the <winsock2.h> header file. */+#undef HAVE_WINSOCK2_H++/* Define to 1 if you have the <ws2tcpip.h> header file. */+#undef HAVE_WS2TCPIP_H++/* Define to 1 if you have the <wspiapi.h> header file. */+#undef HAVE_WSPIAPI_H++/* Define to 1 if the `getaddrinfo' function needs WINVER set. */+#undef NEED_WINVER_XP++/* Define to the address where bug reports for this package should be sent. */+#undef PACKAGE_BUGREPORT++/* Define to the full name of this package. */+#undef PACKAGE_NAME++/* Define to the full name and version of this package. */+#undef PACKAGE_STRING++/* Define to the one symbol short name of this package. */+#undef PACKAGE_TARNAME++/* Define to the version of this package. */+#undef PACKAGE_VERSION++/* Define to 1 if you have the ANSI C header files. */+#undef STDC_HEADERS++/* Define to empty if `const' does not conform to ANSI C. */+#undef const
+ install-sh view
@@ -0,0 +1,295 @@+#!/bin/sh+# install - install a program, script, or datafile++scriptversion=2003-09-24.23++# 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.  It can only install one file at a time, a restriction+# shared with many OS's install programs.++# set DOITPROG to echo to test this script++# Don't use :- since 4.3BSD and earlier shells don't like it.+doit="${DOITPROG-}"++# put in absolute paths if you don't have them in your path; or use env. vars.++mvprog="${MVPROG-mv}"+cpprog="${CPPROG-cp}"+chmodprog="${CHMODPROG-chmod}"+chownprog="${CHOWNPROG-chown}"+chgrpprog="${CHGRPPROG-chgrp}"+stripprog="${STRIPPROG-strip}"+rmprog="${RMPROG-rm}"+mkdirprog="${MKDIRPROG-mkdir}"++transformbasename=+transform_arg=+instcmd="$mvprog"+chmodcmd="$chmodprog 0755"+chowncmd=+chgrpcmd=+stripcmd=+rmcmd="$rmprog -f"+mvcmd="$mvprog"+src=+dst=+dir_arg=++usage="Usage: $0 [OPTION]... SRCFILE DSTFILE+   or: $0 -d DIR1 DIR2...++In the first form, install SRCFILE to DSTFILE, removing SRCFILE by default.+In the second, create the directory path DIR.++Options:+-b=TRANSFORMBASENAME+-c         copy source (using $cpprog) instead of moving (using $mvprog).+-d         create directories instead of installing files.+-g GROUP   $chgrp installed files to GROUP.+-m MODE    $chmod installed files to MODE.+-o USER    $chown installed files to USER.+-s         strip installed files (using $stripprog).+-t=TRANSFORM+--help     display this help and exit.+--version  display version info and exit.++Environment variables override the default commands:+  CHGRPPROG CHMODPROG CHOWNPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG+"++while test -n "$1"; do+  case $1 in+    -b=*) transformbasename=`echo $1 | sed 's/-b=//'`+        shift+        continue;;++    -c) instcmd=$cpprog+        shift+        continue;;++    -d) dir_arg=true+        shift+        continue;;++    -g) chgrpcmd="$chgrpprog $2"+        shift+        shift+        continue;;++    --help) echo "$usage"; exit 0;;++    -m) chmodcmd="$chmodprog $2"+        shift+        shift+        continue;;++    -o) chowncmd="$chownprog $2"+        shift+        shift+        continue;;++    -s) stripcmd=$stripprog+        shift+        continue;;++    -t=*) transformarg=`echo $1 | sed 's/-t=//'`+        shift+        continue;;++    --version) echo "$0 $scriptversion"; exit 0;;++    *)  if test -z "$src"; then+          src=$1+        else+          # this colon is to work around a 386BSD /bin/sh bug+          :+          dst=$1+        fi+        shift+        continue;;+  esac+done++if test -z "$src"; then+  echo "$0: no input file specified." >&2+  exit 1+fi++# Protect names starting with `-'.+case $src in+  -*) src=./$src ;;+esac++if test -n "$dir_arg"; then+  dst=$src+  src=++  if test -d "$dst"; then+    instcmd=:+    chmodcmd=+  else+    instcmd=$mkdirprog+  fi+else+  # Waiting for this to be detected by the "$instcmd $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"; then+    echo "$0: no destination specified." >&2+    exit 1+  fi++  # 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+    dst=$dst/`basename "$src"`+  fi+fi++# This sed command emulates the dirname command.+dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`++# Make sure that the destination directory exists.++# Skip lots of stat calls in the usual case.+if test ! -d "$dstdir"; then+  defaultIFS='+	'+  IFS="${IFS-$defaultIFS}"++  oIFS=$IFS+  # Some sh's can't handle IFS=/ for some reason.+  IFS='%'+  set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'`+  IFS=$oIFS++  pathcomp=++  while test $# -ne 0 ; do+    pathcomp=$pathcomp$1+    shift+    test -d "$pathcomp" || $mkdirprog "$pathcomp"+    pathcomp=$pathcomp/+  done+fi++if test -n "$dir_arg"; then+  $doit $instcmd "$dst" \+    && { test -z "$chowncmd" || $doit $chowncmd "$dst"; } \+    && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } \+    && { test -z "$stripcmd" || $doit $stripcmd "$dst"; } \+    && { test -z "$chmodcmd" || $doit $chmodcmd "$dst"; }++else+  # If we're going to rename the final executable, determine the name now.+  if test -z "$transformarg"; then+    dstfile=`basename "$dst"`+  else+    dstfile=`basename "$dst" $transformbasename \+             | sed $transformarg`$transformbasename+  fi++  # don't allow the sed command to completely eliminate the filename.+  test -z "$dstfile" && dstfile=`basename "$dst"`++  # 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 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0+  trap '(exit $?); exit' 1 2 13 15++  # Move or copy the file name to the temp name+  $doit $instcmd "$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 $instcmd $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 "$dsttmp"; } &&++  # 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.+  {+    if test -f "$dstdir/$dstfile"; then+      $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null \+      || $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null \+      || {+	  echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2+	  (exit 1); exit+      }+    else+      :+    fi+  } &&++  # Now rename the file to the real destination.+  $doit $mvcmd "$dsttmp" "$dstdir/$dstfile"+fi &&++# The final little trick to "correctly" pass the exit status to the exit trap.+{+  (exit 0); exit+}++# 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:
+ network.buildinfo.in view
@@ -0,0 +1,5 @@+executable: cabal+ghc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@+cc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@+c-sources: @EXTRA_SRCS@+extra-libraries: @EXTRA_LIBS@