import System.Console.GetOpt
import Text.PrettyPrint
+#if __GLASGOW_HASKELL__ >= 609
import qualified Control.Exception as Exception
+#else
+import qualified Control.Exception.Extensible as Exception
+#endif
import Data.Maybe
-import Data.Bits
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
import Data.List
import Control.Concurrent
+import Foreign
import Foreign.C
#ifdef mingw32_HOST_OS
-import Foreign
import GHC.ConsoleHandler
#else
import System.Posix hiding (fdToHandle)
in
return (flag_stack, to_modify)
- db_stack <- mapM readParseDatabase final_stack
+ db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
return (db_stack, to_modify)
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
- let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
- `catchError` \e->
- die ("error while parsing " ++ filename ++ ": " ++ show e)
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+readParseDatabase :: Maybe (PackageDBName,Bool)
+ -> PackageDBName
+ -> IO (PackageDBName,PackageDB)
+readParseDatabase mb_user_conf filename
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, filename == user_conf
+ = return (filename, [])
+ | otherwise
+ = do str <- readFile filename
+ let packages = map convertPackageInfoIn $ read str
+ Exception.evaluate packages
+ `catchError` \e->
+ die ("error while parsing " ++ filename ++ ": " ++ show e)
+ return (filename,packages)
-- -----------------------------------------------------------------------------
-- Registering
pkg <- parsePackageInfo expanded
putStrLn "done."
+ let unversioned_deps = filter (not . realVersion) (depends pkg)
+ unless (null unversioned_deps) $
+ die ("Unversioned dependencies found: " ++
+ unwords (map display unversioned_deps))
+
let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
installSignalHandlers = do
threadid <- myThreadId
let
- interrupt = throwTo threadid (Exception.ErrorCall "interrupted")
+ interrupt = Exception.throwTo threadid
+ (Exception.ErrorCall "interrupted")
--
#if !defined(mingw32_HOST_OS)
- installHandler sigQUIT (Catch interrupt) Nothing
+ installHandler sigQUIT (Catch interrupt) Nothing
installHandler sigINT (Catch interrupt) Nothing
return ()
#elif __GLASGOW_HASKELL__ >= 603
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
#endif
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-catchIO = Exception.catch
-#else
-catchIO io handler = io `Exception.catch` handler'
- where handler' (Exception.IOException ioe) = handler ioe
- handler' e = Exception.throw e
-#endif
-
#if mingw32_HOST_OS || mingw32_TARGET_OS
throwIOIO :: Exception.IOException -> IO a
-#if __GLASGOW_HASKELL__ >= 609
throwIOIO = Exception.throwIO
-#else
-throwIOIO ioe = Exception.throwIO (Exception.IOException ioe)
-#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
#endif
catchError :: IO a -> (String -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-catchError io handler = io `Exception.catch` handler'
- where handler' (Exception.ErrorCall err) = handler err
-#else
catchError io handler = io `Exception.catch` handler'
where handler' (Exception.ErrorCall err) = handler err
- handler' e = Exception.throw e
-#endif
-
-onException :: IO a -> IO b -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
-- copied from Cabal's Distribution.Simple.Utils, except that we want
#else
renameFile newFile targetFile
#endif
- `onException` do hClose newHandle
- removeFile newFile
+ `Exception.onException` do hClose newHandle
+ removeFile newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
-- XXX We want to tell fdToHandle what the filepath is,
-- as any exceptions etc will only be able to report the
-- fd currently
- h <- fdToHandle fd `onException` c_close fd
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
+#else
+ fdToHandle (fromIntegral fd)
+#endif
+ `Exception.onException` c_close fd
return (filepath, h)
where
filename = prefix ++ show x ++ suffix