Commits

Even Wiik Thomassen committed f5c6ab8

Imported files from haskell-python. Removed a lot!

Comments (0)

Files changed (933)

+syntax: glob
+*~
+*.swp
+*.hcj

Cabal/DefaultSetup.hs

+import Distribution.Simple
+main = defaultMain

Cabal/Distribution/Compat/CopyFile.hs

+{-# 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 #-}
+-- #hide
+module Distribution.Compat.CopyFile (
+  copyFile,
+  copyOrdinaryFile,
+  copyExecutableFile,
+  setFileOrdinary,
+  setFileExecutable,
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+
+import Control.Monad
+         ( when )
+import Control.Exception
+         ( bracket, bracketOnError )
+import Distribution.Compat.Exception
+         ( catchIO )
+#if __GLASGOW_HASKELL__ >= 608
+import Distribution.Compat.Exception
+         ( throwIOIO )
+import System.IO.Error
+         ( ioeSetLocation )
+#endif
+import System.Directory
+         ( renameFile, removeFile )
+import Distribution.Compat.TempFile
+         ( openBinaryTempFile )
+import System.FilePath
+         ( takeDirectory )
+import System.IO
+         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
+import Foreign
+         ( allocaBytes )
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Types
+         ( FileMode )
+import System.Posix.Internals
+         ( c_chmod )
+import Foreign.C
+         ( withCString )
+#if __GLASGOW_HASKELL__ >= 608
+import Foreign.C
+         ( throwErrnoPathIfMinus1_ )
+#else
+import Foreign.C
+         ( throwErrnoIfMinus1_ )
+#endif
+#endif /* mingw32_HOST_OS */
+
+copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
+copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest
+copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
+
+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
+
+copyFile :: FilePath -> FilePath -> IO ()
+#ifdef __GLASGOW_HASKELL__
+copyFile fromFPath toFPath =
+  copy
+#if __GLASGOW_HASKELL__ >= 608
+    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
+#endif
+    where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+                 bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
+                 do allocaBytes bufferSize $ copyContents hFrom hTmp
+                    hClose hTmp
+                    renameFile tmpFPath toFPath
+          openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
+          cleanTmp (tmpFPath, hTmp) = do
+            hClose hTmp          `catchIO` \_ -> return ()
+            removeFile tmpFPath  `catchIO` \_ -> return ()
+          bufferSize = 4096
+
+          copyContents hFrom hTo buffer = do
+                  count <- hGetBuf hFrom buffer bufferSize
+                  when (count > 0) $ do
+                          hPutBuf hTo buffer count
+                          copyContents hFrom hTo buffer
+#else
+copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
+#endif

Cabal/Distribution/Compat/Exception.hs

+{-# 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 #-}
+
+#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
+#define NEW_EXCEPTION
+#endif
+
+module Distribution.Compat.Exception
+    (onException, catchIO, catchExit, throwIOIO)
+    where
+
+import System.Exit
+import qualified Control.Exception as Exception
+
+onException :: IO a -> IO b -> IO a
+#ifdef NEW_EXCEPTION
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+                                                    Exception.throw e
+#endif
+
+throwIOIO :: Exception.IOException -> IO a
+#ifdef NEW_EXCEPTION
+throwIOIO = Exception.throwIO
+#else
+throwIOIO = Exception.throwIO . Exception.IOException
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchIO = Exception.catch
+#else
+catchIO = Exception.catchJust Exception.ioErrors
+#endif
+
+catchExit :: IO a -> (ExitCode -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchExit = Exception.catch
+#else
+catchExit = Exception.catchJust exitExceptions
+    where exitExceptions (Exception.ExitException ee) = Just ee
+          exitExceptions _                            = Nothing
+#endif
+

Cabal/Distribution/Compat/ReadP.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Compat.ReadP
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Portability :  portable
+--
+-- This is a library of parser combinators, originally written by Koen Claessen.
+-- It parses all alternatives in parallel, so it never keeps hold of
+-- the beginning of the input string, a common source of space leaks with
+-- other parsers.  The '(+++)' choice combinator is genuinely commutative;
+-- it makes no difference which branch is \"shorter\".
+--
+-- See also Koen's paper /Parallel Parsing Processes/
+-- (<http://www.cs.chalmers.se/~koen/publications.html>).
+--
+-- This version of ReadP has been locally hacked to make it H98, by
+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
+--
+-----------------------------------------------------------------------------
+
+module Distribution.Compat.ReadP
+  (
+  -- * The 'ReadP' type
+  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus
+
+  -- * Primitive operations
+  get,        -- :: ReadP Char
+  look,       -- :: ReadP String
+  (+++),      -- :: ReadP a -> ReadP a -> ReadP a
+  (<++),      -- :: ReadP a -> ReadP a -> ReadP a
+  gather,     -- :: ReadP a -> ReadP (String, a)
+
+  -- * Other operations
+  pfail,      -- :: ReadP a
+  satisfy,    -- :: (Char -> Bool) -> ReadP Char
+  char,       -- :: Char -> ReadP Char
+  string,     -- :: String -> ReadP String
+  munch,      -- :: (Char -> Bool) -> ReadP String
+  munch1,     -- :: (Char -> Bool) -> ReadP String
+  skipSpaces, -- :: ReadP ()
+  choice,     -- :: [ReadP a] -> ReadP a
+  count,      -- :: Int -> ReadP a -> ReadP [a]
+  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
+  option,     -- :: a -> ReadP a -> ReadP a
+  optional,   -- :: ReadP a -> ReadP ()
+  many,       -- :: ReadP a -> ReadP [a]
+  many1,      -- :: ReadP a -> ReadP [a]
+  skipMany,   -- :: ReadP a -> ReadP ()
+  skipMany1,  -- :: ReadP a -> ReadP ()
+  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]
+  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]
+  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]
+  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]
+  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]
+
+  -- * Running a parser
+  ReadS,      -- :: *; = String -> [(a,String)]
+  readP_to_S, -- :: ReadP a -> ReadS a
+  readS_to_P  -- :: ReadS a -> ReadP a
+
+  -- * Properties
+  -- $properties
+  )
+ where
+
+import Control.Monad( MonadPlus(..), liftM2 )
+import Data.Char (isSpace)
+
+infixr 5 +++, <++
+
+-- ---------------------------------------------------------------------------
+-- The P type
+-- is representation type -- should be kept abstract
+
+data P s a
+  = Get (s -> P s a)
+  | Look ([s] -> P s a)
+  | Fail
+  | Result a (P s a)
+  | Final [(a,[s])] -- invariant: list is non-empty!
+
+-- Monad, MonadPlus
+
+instance Monad (P s) where
+  return x = Result x Fail
+
+  (Get f)      >>= k = Get (\c -> f c >>= k)
+  (Look f)     >>= k = Look (\s -> f s >>= k)
+  Fail         >>= _ = Fail
+  (Result x p) >>= k = k x `mplus` (p >>= k)
+  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
+
+  fail _ = Fail
+
+instance MonadPlus (P s) where
+  mzero = Fail
+
+  -- most common case: two gets are combined
+  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)
+
+  -- results are delivered as soon as possible
+  Result x p `mplus` q          = Result x (p `mplus` q)
+  p          `mplus` Result x q = Result x (p `mplus` q)
+
+  -- fail disappears
+  Fail       `mplus` p          = p
+  p          `mplus` Fail       = p
+
+  -- two finals are combined
+  -- final + look becomes one look and one final (=optimization)
+  -- final + sthg else becomes one look and one final
+  Final r    `mplus` Final t    = Final (r ++ t)
+  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))
+  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))
+  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))
+  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))
+
+  -- two looks are combined (=optimization)
+  -- look + sthg else floats upwards
+  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)
+  Look f     `mplus` p          = Look (\s -> f s `mplus` p)
+  p          `mplus` Look f     = Look (\s -> p `mplus` f s)
+
+-- ---------------------------------------------------------------------------
+-- The ReadP type
+
+newtype Parser r s a = R ((a -> P s r) -> P s r)
+type ReadP r a = Parser r Char a
+
+-- Functor, Monad, MonadPlus
+
+instance Functor (Parser r s) where
+  fmap h (R f) = R (\k -> f (k . h))
+
+instance Monad (Parser r s) where
+  return x  = R (\k -> k x)
+  fail _    = R (\_ -> Fail)
+  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
+
+--instance MonadPlus (Parser r s) where
+--  mzero = pfail
+--  mplus = (+++)
+
+-- ---------------------------------------------------------------------------
+-- Operations over P
+
+final :: [(a,[s])] -> P s a
+-- Maintains invariant for Final constructor
+final [] = Fail
+final r  = Final r
+
+run :: P c a -> ([c] -> [(a, [c])])
+run (Get f)      (c:s) = run (f c) s
+run (Look f)     s     = run (f s) s
+run (Result x p) s     = (x,s) : run p s
+run (Final r)    _     = r
+run _            _     = []
+
+-- ---------------------------------------------------------------------------
+-- Operations over ReadP
+
+get :: ReadP r Char
+-- ^ Consumes and returns the next character.
+--   Fails if there is no input left.
+get = R Get
+
+look :: ReadP r String
+-- ^ Look-ahead: returns the part of the input that is left, without
+--   consuming it.
+look = R Look
+
+pfail :: ReadP r a
+-- ^ Always fails.
+pfail = R (\_ -> Fail)
+
+(+++) :: ReadP r a -> ReadP r a -> ReadP r a
+-- ^ Symmetric choice.
+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
+
+(<++) :: ReadP a a -> ReadP r a -> ReadP r a
+-- ^ Local, exclusive, left-biased choice: If left parser
+--   locally produces any result at all, then right parser is
+--   not used.
+R f <++ q =
+  do s <- look
+     probe (f return) s 0
+ where
+  probe (Get f')       (c:s) n = probe (f' c) s (n+1 :: Int)
+  probe (Look f')      s     n = probe (f' s) s n
+  probe p@(Result _ _) _     n = discard n >> R (p >>=)
+  probe (Final r)      _     _ = R (Final r >>=)
+  probe _              _     _ = q
+
+  discard 0 = return ()
+  discard n  = get >> discard (n-1 :: Int)
+
+gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
+-- ^ Transforms a parser into one that does the same, but
+--   in addition returns the exact characters read.
+--   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
+--   is built using any occurrences of readS_to_P.
+gather (R m) =
+  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
+ where
+  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
+  gath _ Fail         = Fail
+  gath l (Look f)     = Look (\s -> gath l (f s))
+  gath l (Result k p) = k (l []) `mplus` gath l p
+  gath _ (Final _)    = error "do not use readS_to_P in gather!"
+
+-- ---------------------------------------------------------------------------
+-- Derived operations
+
+satisfy :: (Char -> Bool) -> ReadP r Char
+-- ^ Consumes and returns the next character, if it satisfies the
+--   specified predicate.
+satisfy p = do c <- get; if p c then return c else pfail
+
+char :: Char -> ReadP r Char
+-- ^ Parses and returns the specified character.
+char c = satisfy (c ==)
+
+string :: String -> ReadP r String
+-- ^ Parses and returns the specified string.
+string this = do s <- look; scan this s
+ where
+  scan []     _               = do return this
+  scan (x:xs) (y:ys) | x == y = do get >> scan xs ys
+  scan _      _               = do pfail
+
+munch :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first zero or more characters satisfying the predicate.
+munch p =
+  do s <- look
+     scan s
+ where
+  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
+  scan _            = do return ""
+
+munch1 :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first one or more characters satisfying the predicate.
+munch1 p =
+  do c <- get
+     if p c then do s <- munch p; return (c:s)
+            else pfail
+
+choice :: [ReadP r a] -> ReadP r a
+-- ^ Combines all parsers in the specified list.
+choice []     = pfail
+choice [p]    = p
+choice (p:ps) = p +++ choice ps
+
+skipSpaces :: ReadP r ()
+-- ^ Skips all whitespace.
+skipSpaces =
+  do s <- look
+     skip s
+ where
+  skip (c:s) | isSpace c = do _ <- get; skip s
+  skip _                 = do return ()
+
+count :: Int -> ReadP r a -> ReadP r [a]
+-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
+--   results is returned.
+count n p = sequence (replicate n p)
+
+between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
+-- ^ @ between open close p @ parses @open@, followed by @p@ and finally
+--   @close@. Only the value of @p@ is returned.
+between open close p = do _ <- open
+                          x <- p
+                          _ <- close
+                          return x
+
+option :: a -> ReadP r a -> ReadP r a
+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming
+--   any input.
+option x p = p +++ return x
+
+optional :: ReadP r a -> ReadP r ()
+-- ^ @optional p@ optionally parses @p@ and always returns @()@.
+optional p = (p >> return ()) +++ return ()
+
+many :: ReadP r a -> ReadP r [a]
+-- ^ Parses zero or more occurrences of the given parser.
+many p = return [] +++ many1 p
+
+many1 :: ReadP r a -> ReadP r [a]
+-- ^ Parses one or more occurrences of the given parser.
+many1 p = liftM2 (:) p (many p)
+
+skipMany :: ReadP r a -> ReadP r ()
+-- ^ Like 'many', but discards the result.
+skipMany p = many p >> return ()
+
+skipMany1 :: ReadP r a -> ReadP r ()
+-- ^ Like 'many1', but discards the result.
+skipMany1 p = p >> skipMany p
+
+sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
+--   Returns a list of values returned by @p@.
+sepBy p sep = sepBy1 p sep +++ return []
+
+sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
+--   Returns a list of values returned by @p@.
+sepBy1 p sep = liftM2 (:) p (many (sep >> p))
+
+endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
+--   by @sep@.
+endBy p sep = many (do x <- p ; _ <- sep ; return x)
+
+endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
+--   by @sep@.
+endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
+
+chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
+--   Returns a value produced by a /right/ associative application of all
+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is
+--   returned.
+chainr p op x = chainr1 p op +++ return x
+
+chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
+--   Returns a value produced by a /left/ associative application of all
+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is
+--   returned.
+chainl p op x = chainl1 p op +++ return x
+
+chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainr', but parses one or more occurrences of @p@.
+chainr1 p op = scan
+  where scan   = p >>= rest
+        rest x = do f <- op
+                    y <- scan
+                    return (f x y)
+                 +++ return x
+
+chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainl', but parses one or more occurrences of @p@.
+chainl1 p op = p >>= rest
+  where rest x = do f <- op
+                    y <- p
+                    rest (f x y)
+                 +++ return x
+
+manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
+--   succeeds. Returns a list of values returned by @p@.
+manyTill p end = scan
+  where scan = (end >> return []) <++ (liftM2 (:) p scan)
+
+-- ---------------------------------------------------------------------------
+-- Converting between ReadP and Read
+
+readP_to_S :: ReadP a a -> ReadS a
+-- ^ Converts a parser into a Haskell ReadS-style function.
+--   This is the main way in which you can \"run\" a 'ReadP' parser:
+--   the expanded type is
+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
+readP_to_S (R f) = run (f return)
+
+readS_to_P :: ReadS a -> ReadP r a
+-- ^ Converts a Haskell ReadS-style function into a parser.
+--   Warning: This introduces local backtracking in the resulting
+--   parser, and therefore a possible inefficiency.
+readS_to_P r =
+  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+
+-- ---------------------------------------------------------------------------
+-- QuickCheck properties that hold for the combinators
+
+{- $properties
+The following are QuickCheck specifications of what the combinators do.
+These can be seen as formal specifications of the behavior of the
+combinators.
+
+We use bags to give semantics to the combinators.
+
+>  type Bag a = [a]
+
+Equality on bags does not care about the order of elements.
+
+>  (=~) :: Ord a => Bag a -> Bag a -> Bool
+>  xs =~ ys = sort xs == sort ys
+
+A special equality operator to avoid unresolved overloading
+when testing the properties.
+
+>  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
+>  (=~.) = (=~)
+
+Here follow the properties:
+
+>  prop_Get_Nil =
+>    readP_to_S get [] =~ []
+>
+>  prop_Get_Cons c s =
+>    readP_to_S get (c:s) =~ [(c,s)]
+>
+>  prop_Look s =
+>    readP_to_S look s =~ [(s,s)]
+>
+>  prop_Fail s =
+>    readP_to_S pfail s =~. []
+>
+>  prop_Return x s =
+>    readP_to_S (return x) s =~. [(x,s)]
+>
+>  prop_Bind p k s =
+>    readP_to_S (p >>= k) s =~.
+>      [ ys''
+>      | (x,s') <- readP_to_S p s
+>      , ys''   <- readP_to_S (k (x::Int)) s'
+>      ]
+>
+>  prop_Plus p q s =
+>    readP_to_S (p +++ q) s =~.
+>      (readP_to_S p s ++ readP_to_S q s)
+>
+>  prop_LeftPlus p q s =
+>    readP_to_S (p <++ q) s =~.
+>      (readP_to_S p s +<+ readP_to_S q s)
+>   where
+>    [] +<+ ys = ys
+>    xs +<+ _  = xs
+>
+>  prop_Gather s =
+>    forAll readPWithoutReadS $ \p ->
+>      readP_to_S (gather p) s =~
+>	 [ ((pre,x::Int),s')
+>	 | (x,s') <- readP_to_S p s
+>	 , let pre = take (length s - length s') s
+>	 ]
+>
+>  prop_String_Yes this s =
+>    readP_to_S (string this) (this ++ s) =~
+>      [(this,s)]
+>
+>  prop_String_Maybe this s =
+>    readP_to_S (string this) s =~
+>      [(this, drop (length this) s) | this `isPrefixOf` s]
+>
+>  prop_Munch p s =
+>    readP_to_S (munch p) s =~
+>      [(takeWhile p s, dropWhile p s)]
+>
+>  prop_Munch1 p s =
+>    readP_to_S (munch1 p) s =~
+>      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
+>
+>  prop_Choice ps s =
+>    readP_to_S (choice ps) s =~.
+>      readP_to_S (foldr (+++) pfail ps) s
+>
+>  prop_ReadS r s =
+>    readP_to_S (readS_to_P r) s =~. r s
+-}
+

Cabal/Distribution/Compat/TempFile.hs

+{-# 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 #-}
+-- #hide
+module Distribution.Compat.TempFile (
+  openTempFile,
+  openBinaryTempFile,
+  openNewBinaryFile,
+  createTempDirectory,
+  ) where
+
+
+import System.FilePath        ((</>))
+import Foreign.C              (eEXIST)
+
+#if __NHC__ || __HUGS__
+import System.IO              (openFile, openBinaryFile,
+                               Handle, IOMode(ReadWriteMode))
+import System.Directory       (doesFileExist)
+import System.FilePath        ((<.>), splitExtension)
+import System.IO.Error        (try, isAlreadyExistsError)
+#else
+import System.IO              (Handle, openTempFile, openBinaryTempFile)
+import Data.Bits              ((.|.))
+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
+                               o_BINARY, o_NONBLOCK, o_NOCTTY)
+import System.IO.Error        (try, isAlreadyExistsError)
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C              (withCString)
+#endif
+import Foreign.C              (CInt)
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle.FD       (fdToHandle)
+#else
+import GHC.Handle             (fdToHandle)
+#endif
+import Distribution.Compat.Exception (onException)
+#endif
+import Foreign.C              (getErrno, errnoToIOError)
+
+#if __NHC__
+import System.Posix.Types     (CPid(..))
+foreign import ccall unsafe "getpid" c_getpid :: IO CPid
+#else
+import System.Posix.Internals (c_getpid)
+#endif
+
+#ifdef mingw32_HOST_OS
+import System.Directory       ( createDirectory )
+#else
+import qualified System.Posix
+#endif
+
+-- ------------------------------------------------------------
+-- * temporary files
+-- ------------------------------------------------------------
+
+-- This is here for Haskell implementations that do not come with
+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
+-- TODO: Not sure about jhc
+
+#if __NHC__ || __HUGS__
+-- use a temporary filename that doesn't already exist.
+-- NB. *not* secure (we don't atomically lock the tmp file we get)
+openTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openTempFile tmp_dir template
+  = do x <- getProcessID
+       findTempName x
+  where
+    (templateBase, templateExt) = splitExtension template
+    findTempName :: Int -> IO (FilePath, Handle)
+    findTempName x
+      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+           b  <- doesFileExist path
+           if b then findTempName (x+1)
+                else do hnd <- openFile path ReadWriteMode
+                        return (path, hnd)
+
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template
+  = do x <- getProcessID
+       findTempName x
+  where
+    (templateBase, templateExt) = splitExtension template
+    findTempName :: Int -> IO (FilePath, Handle)
+    findTempName x
+      = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
+           b  <- doesFileExist path
+           if b then findTempName (x+1)
+                else do hnd <- openBinaryFile path ReadWriteMode
+                        return (path, hnd)
+
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile = openBinaryTempFile
+
+getProcessID :: IO Int
+getProcessID = fmap fromIntegral c_getpid
+#else
+-- This is a copy/paste of the openBinaryTempFile definition, but
+-- if uses 666 rather than 600 for the permissions. The base library
+-- needs to be changed to make this better.
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile dir template = do
+  pid <- c_getpid
+  findTempName pid
+  where
+    -- We split off the last extension, so we can use .foo.ext files
+    -- for temporary files (hidden on Unix OSes). Unfortunately we're
+    -- below filepath in the hierarchy here.
+    (prefix,suffix) =
+       case break (== '.') $ reverse template of
+         -- First case: template contains no '.'s. Just re-reverse it.
+         (rev_suffix, "")       -> (reverse rev_suffix, "")
+         -- Second case: template contains at least one '.'. Strip the
+         -- dot from the prefix and prepend it to the suffix (if we don't
+         -- do this, the unique number will get added after the '.' and
+         -- thus be part of the extension, which is wrong.)
+         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+         -- Otherwise, something is wrong, because (break (== '.')) should
+         -- always return a pair with either the empty string or a string
+         -- beginning with '.' as the second component.
+         _                      -> error "bug in System.IO.openTempFile"
+
+    oflags = rw_flags .|. o_EXCL .|. o_BINARY
+
+#if __GLASGOW_HASKELL__ < 611
+    withFilePath = withCString
+#endif
+
+    findTempName x = do
+      fd <- withFilePath filepath $ \ f ->
+              c_open f oflags 0o666
+      if fd < 0
+       then do
+         errno <- getErrno
+         if errno == eEXIST
+           then findTempName (x+1)
+           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+       else do
+         -- TODO: We want to tell fdToHandle what the filepath is,
+         -- as any exceptions etc will only be able to report the
+         -- fd currently
+         h <-
+#if __GLASGOW_HASKELL__ >= 609
+              fdToHandle fd
+#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
+              -- fdToHandle is borked on Windows with ghc-6.6.x
+              openFd (fromIntegral fd) Nothing False filepath
+                                       ReadWriteMode True
+#else
+              fdToHandle (fromIntegral fd)
+#endif
+              `onException` c_close fd
+         return (filepath, h)
+      where
+        filename        = prefix ++ show x ++ suffix
+        filepath        = dir `combine` filename
+
+        -- FIXME: bits copied from System.FilePath
+        combine a b
+                  | null b = a
+                  | null a = b
+                  | last a == pathSeparator = a ++ b
+                  | otherwise = a ++ [pathSeparator] ++ b
+
+-- FIXME: Should use filepath library
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+-- FIXME: Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags    = o_NONBLOCK   .|. o_NOCTTY
+output_flags = std_flags    .|. o_CREAT
+rw_flags     = output_flags .|. o_RDWR
+#endif
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+  pid <- c_getpid
+  findTempName pid
+  where
+    findTempName x = do
+      let dirpath = dir </> template ++ show x
+      r <- try $ mkPrivateDir dirpath
+      case r of
+        Right _ -> return dirpath
+        Left  e | isAlreadyExistsError e -> findTempName (x+1)
+                | otherwise              -> ioError e
+
+mkPrivateDir :: String -> IO ()
+#ifdef mingw32_HOST_OS
+mkPrivateDir s = createDirectory s
+#else
+mkPrivateDir s = System.Posix.createDirectory s 0o700
+#endif

Cabal/Distribution/Compiler.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Compiler
+-- Copyright   :  Isaac Jones 2003-2004
+--
+-- Maintainer  :  cabal-devel@haskell.org
+-- Portability :  portable
+--
+-- This has an enumeration of the various compilers that Cabal knows about. It
+-- also specifies the default compiler. Sadly you'll often see code that does
+-- case analysis on this compiler flavour enumeration like:
+--
+-- > case compilerFlavor comp of
+-- >   GHC -> GHC.getInstalledPackages verbosity packageDb progconf
+-- >   JHC -> JHC.getInstalledPackages verbosity packageDb progconf
+--
+-- Obviously it would be better to use the proper 'Compiler' abstraction
+-- because that would keep all the compiler-specific code together.
+-- Unfortunately we cannot make this change yet without breaking the
+-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
+-- moment we just have to live with this deficiency. If you're interested, see
+-- ticket #50.
+
+{- 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 Isaac Jones 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. -}
+
+module Distribution.Compiler (
+  -- * Compiler flavor
+  CompilerFlavor(..),
+  buildCompilerFlavor,
+  defaultCompilerFlavor,
+  parseCompilerFlavorCompat,
+
+  -- * Compiler id
+  CompilerId(..),
+  ) where
+
+import Distribution.Version (Version(..))
+
+import qualified System.Info (compilerName)
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+
+import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
+import Control.Monad (when)
+
+data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
+                    | OtherCompiler String
+  deriving (Show, Read, Eq, Ord)
+
+knownCompilerFlavors :: [CompilerFlavor]
+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
+
+instance Text CompilerFlavor where
+  disp (OtherCompiler name) = Disp.text name
+  disp NHC                  = Disp.text "nhc98"
+  disp other                = Disp.text (lowercase (show other))
+
+  parse = do
+    comp <- Parse.munch1 Char.isAlphaNum
+    when (all Char.isDigit comp) Parse.pfail
+    return (classifyCompilerFlavor comp)
+
+classifyCompilerFlavor :: String -> CompilerFlavor
+classifyCompilerFlavor s =
+  case lookup (lowercase s) compilerMap of
+    Just compiler -> compiler
+    Nothing       -> OtherCompiler s
+  where
+    compilerMap = [ (display compiler, compiler)
+                  | compiler <- knownCompilerFlavors ]
+
+
+--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use
+-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.
+
+-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.
+--
+-- It is compatible in the sense that it accepts only the same strings,
+-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.
+-- The point of this is that we do not allow extra valid values that would
+-- upset older Cabal versions that had a stricter parser however we cope with
+-- new values more gracefully so that we'll be able to introduce new value in
+-- future without breaking things so much.
+--
+parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor
+parseCompilerFlavorCompat = do
+  comp <- Parse.munch1 Char.isAlphaNum
+  when (all Char.isDigit comp) Parse.pfail
+  case lookup comp compilerMap of
+    Just compiler -> return compiler
+    Nothing       -> return (OtherCompiler comp)
+  where
+    compilerMap = [ (show compiler, compiler)
+                  | compiler <- knownCompilerFlavors
+                  , compiler /= YHC ]
+