X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=29040e4a87ea7f119d7493b3ae38f58102544e11;hb=0e7b8c87f32cbdbb931a01537a578ee30ac2e026;hp=421c9035ae65e26edcd5f029f8943f4f469f78d1;hpb=87c72934ead49e89de5871b6f98cad048e6af560;p=ghc-hetmet.git

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index 421c903..29040e4 100644
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -41,6 +41,7 @@ import CString
 #endif
 #endif
 
+main :: IO ()
 main = do
   args <- getArgs
 
@@ -69,6 +70,7 @@ data Flag
   | DumpVersion
   deriving (Eq)
 
+isAction :: Flag -> Bool
 isAction (Config _)     = False
 isAction (Field _)      = False
 isAction (Input _)      = False
@@ -88,6 +90,7 @@ version = tail "\
 usageHeader :: String -> String
 usageHeader prog = "Usage: " ++ prog ++ " [OPTION...]\n"
 
+flags :: [OptDescr Flag]
 flags = [
   Option ['f'] ["config-file"] (ReqArg Config "FILE")
 	"use the specified package config file",
@@ -124,6 +127,7 @@ flags = [
       (nm,[]) -> DefinedName nm []
       (nm,_:val) -> DefinedName nm val
 
+runit :: [Flag] -> IO ()
 runit clis = do
   let err_msg = "missing -f option, location of package.conf unknown\n"
   conf_filenames <- 
@@ -199,7 +203,7 @@ showPackage :: [[PackageConfig]]
 	    -> String
 	    -> [PackageConfig -> [String]]
 	    -> IO ()
-showPackage pkg_confs filename pkg_name fields =
+showPackage pkg_confs _ pkg_name fields =
   case [ p | pkgs <- pkg_confs, p <- pkgs, name p == pkg_name ] of
     []    -> die ("can't find package `" ++ pkg_name ++ "'\n")
     [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
@@ -314,6 +318,7 @@ validatePackageConfig pkg pkg_confs@(pkgs:_) auto_ghci_libs updatePkg force = do
        | otherwise = pkgs
   return (existing_pkgs ++ [pkg])
 
+checkDir :: Bool -> String -> IO ()
 checkDir force d
  | "$libdir" `isPrefixOf` d = return ()
 	-- can't check this, because we don't know what $libdir is
@@ -338,26 +343,26 @@ checkHSLib dirs auto_ghci_libs force lib = do
 				 "' on library path") 
 	(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 
+doesLibExistIn :: String -> String -> IO Bool
 doesLibExistIn lib d
  | "$libdir" `isPrefixOf` d = return True
  | otherwise                = doesFileExist (d ++ '/':lib)
 
 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do
-  let ghci_lib_file = lib ++ ".o"
-      ghci_lib_path = batch_lib_dir ++ '/':ghci_lib_file
-  bs <- mapM (\d -> doesFileExist (d ++ '/':ghci_lib_file)) dirs
-  case [ dir | (exists,dir) <- zip bs dirs, exists ] of
-        [] | auto_build -> 
-		autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
-	   | otherwise  -> 
-		hPutStrLn stderr ("warning: can't find GHCi lib `"
-					 ++ ghci_lib_file ++ "'")
-   	(dir:_) -> return ()
+checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
+  | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
+  | otherwise  = do
+      bs <- mapM (doesLibExistIn ghci_lib_file) dirs
+      case [dir | (exists,dir) <- zip bs dirs, exists] of
+        []    -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'")
+   	(_:_) -> return ()
+  where
+    ghci_lib_file = lib ++ ".o"
 
 -- automatically build the GHCi version of a batch lib, 
 -- using ld --whole-archive.
 
+autoBuildGHCiLib :: String -> String -> String -> IO ()
 autoBuildGHCiLib dir batch_file ghci_file = do
   let ghci_lib_file  = dir ++ '/':ghci_file
       batch_lib_file = dir ++ '/':batch_file
@@ -366,9 +371,15 @@ autoBuildGHCiLib dir batch_file ghci_file = do
   system("ld -r -x -o " ++ ghci_lib_file ++ 
 	 " -all_load " ++ batch_lib_file)
 #else
+#ifdef mingw32_HOST_OS
+  execDir <- getExecDir "/bin/ghc-pkg.exe"
+  system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ ghci_lib_file ++ 
+	 " --whole-archive " ++ batch_lib_file)
+#else
   system("ld -r -x -o " ++ ghci_lib_file ++ 
 	 " --whole-archive " ++ batch_lib_file)
 #endif
+#endif
   hPutStrLn stderr (" done.")
 
 -----------------------------------------------------------------------------
@@ -406,21 +417,27 @@ expandEnvVars pkg defines force = do
 	      , extra_frameworks= e_frames
 	      })
   where
-   expandStrings = mapM expandString
-   
-    -- Just for fun, keep this in the IO monad.
+   expandStrings :: [String] -> IO [String]
+   expandStrings = liftM concat . mapM expandSpecial
+
+   -- Permit substitutions for list-valued variables (but only when
+   -- they occur alone), e.g., package_deps["${deps}"] where env var
+   -- (say) 'deps' is "base,haskell98,network"
+   expandSpecial :: String -> IO [String]
+   expandSpecial str =
+      let expand f = liftM f $ expandString str
+      in case splitString str of
+         [Var _] -> expand (wordsBy (== ','))
+         _ -> expand (\x -> [x])
+
    expandString :: String -> IO String
-   expandString str =
-     case break (=='$') str of
-       (xs, _:'{':rs) ->
-         case span (/='}') rs of
-	   (nm,_:remainder) -> do
-	      nm'  <- lookupEnvVar nm
-	      str' <- expandString remainder
-	      return (xs ++ nm' ++ str')
-	   _ -> return str -- no closing '}'
-       _ -> return str	   
+   expandString = liftM concat . mapM expandElem . splitString
 
+   expandElem :: Elem -> IO String
+   expandElem (String s) = return s
+   expandElem (Var v)    = lookupEnvVar v
+
+   lookupEnvVar :: String -> IO String
    lookupEnvVar nm = 
      case lookup nm defines of
        Just x | not (null x) -> return x
@@ -430,6 +447,25 @@ expandEnvVars pkg defines force = do
 					show nm)
 		      return "")
 
+data Elem = String String | Var String
+
+splitString :: String -> [Elem]
+splitString "" = []
+splitString str =
+   case break (== '$') str of
+      (pre, _:'{':xs) ->
+         case span (/= '}') xs of
+            (var, _:suf) ->
+               (if null pre then id else (String pre :)) (Var var : splitString suf)
+            _ -> [String str]   -- no closing brace
+      _ -> [String str]   -- no dollar/opening brace combo
+
+-- wordsBy isSpace == words
+wordsBy :: (Char -> Bool) -> String -> [String]
+wordsBy p s = case dropWhile p s of
+  "" -> []
+  s' -> w : wordsBy p s'' where (w,s'') = break p s'
+
 -----------------------------------------------------------------------------
 
 getProgramName :: IO String
@@ -497,5 +533,5 @@ foreign import stdcall "GetModuleFileNameA" unsafe
   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 #else
 getExecDir :: String -> IO (Maybe String) 
-getExecDir s = do return Nothing
+getExecDir _ = return Nothing
 #endif