X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverUtil.hs;h=264be5cee5baa62c64a99a4ba78994768de3e5ed;hb=174e46d5173abe64a5a05e26864d1339f3bcbe61;hp=7d6e6eb665f8bede42c8707c588ee7f6bbe13721;hpb=292c077de7dbe98eb44911648f16e243b40db2ac;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 7d6e6eb..264be5c 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.27 2001/08/16 11:06:10 simonmar Exp $ -- -- Utils for the driver -- @@ -9,65 +9,28 @@ module DriverUtil where +#include "../includes/config.h" #include "HsVersions.h" -import Config import Util +import Panic +import Config ( cLeadingUnderscore ) import IOExts import Exception import Dynamic import RegexString +import Directory ( getDirectoryContents ) import IO -import System import List import Char import Monad + ----------------------------------------------------------------------------- -- Errors -short_usage = "Usage: For basic information, try the `--help' option." - -GLOBAL_VAR(v_Path_usage, "", String) - -long_usage = do - usage_path <- readIORef v_Path_usage - usage <- readFile usage_path - dump usage - exitWith ExitSuccess - where - dump "" = return () - dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s - dump (c:s) = hPutChar stderr c >> dump s - -data BarfKind - = PhaseFailed String ExitCode - | Interrupted - | UsageError String -- prints the short usage msg after the error - | OtherError String -- just prints the error message - deriving Eq - -GLOBAL_VAR(v_Prog_name, "ghc", String) - -get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk! - -instance Show BarfKind where - showsPrec _ e = showString get_prog_name . showString ": " . showBarf e - -showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage -showBarf (OtherError str) = showString str -showBarf (PhaseFailed phase code) = - showString phase . showString " failed, code = " . shows code -showBarf (Interrupted) = showString "interrupted" - -unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f)) - -barfKindTc = mkTyCon "BarfKind" -instance Typeable BarfKind where - typeOf _ = mkAppTy barfKindTc [] - ----------------------------------------------------------------------------- -- Reading OPTIONS pragmas @@ -76,7 +39,7 @@ getOptionsFromSource -> IO [String] -- options, if any getOptionsFromSource file = do h <- openFile file ReadMode - catchJust ioErrors (look h) + catchJust ioErrors (look h `finally` hClose h) (\e -> if isEOFError e then return [] else ioError e) where look h = do @@ -86,14 +49,36 @@ getOptionsFromSource file | prefixMatch "#" l -> look h | prefixMatch "{-# LINE" l -> look h -- -} | Just (opts:_) <- matchRegex optionRegex l - -> return (words opts) + -> do rest <- look h + return (words opts ++ rest) | otherwise -> return [] optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -} ----------------------------------------------------------------------------- +-- A version of getDirectoryContents that is non-fatal if the +-- directory doesn't exist. + +softGetDirectoryContents d + = IO.catch (getDirectoryContents d) + (\_ -> do hPutStrLn stderr + ("WARNING: error while reading directory " ++ d) + return [] + ) + +----------------------------------------------------------------------------- +-- Prefixing underscore to linker-level names +prefixUnderscore :: String -> String +prefixUnderscore + | cLeadingUnderscore == "YES" = ('_':) + | otherwise = id + +----------------------------------------------------------------------------- -- Utils +unknownFlagErr :: String -> a +unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f)) + my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a]) my_partition _ [] = ([],[]) my_partition p (a:as) @@ -103,8 +88,8 @@ my_partition p (a:as) Just b -> ((a,b):bs,cs) my_prefix_match :: String -> String -> Maybe String -my_prefix_match [] rest = Just rest -my_prefix_match (_:_) [] = Nothing +my_prefix_match [] rest = Just rest +my_prefix_match (_:_) [] = Nothing my_prefix_match (p:pat) (r:rest) | p == r = my_prefix_match pat rest | otherwise = Nothing @@ -114,6 +99,15 @@ later = flip finally handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a handleDyn = flip catchDyn +handle :: (Exception -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 501 +handle = flip Exception.catchAllIO +#else +handle h f = f `Exception.catch` \e -> case e of + ExitException _ -> throw e + _ -> h e +#endif + split :: Char -> String -> [String] split c s = case rest of [] -> [chunk] @@ -130,13 +124,28 @@ addNoDups var x = do xs <- readIORef var unless (x `elem` xs) $ writeIORef var (x:xs) -splitFilename :: String -> (String,String) -splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext) - where (rev_ext, rev_basename) = span ('.' /=) (reverse f) - stripDot ('.':xs) = xs - stripDot xs = xs +------------------------------------------------------ +-- Filename manipulation +------------------------------------------------------ + +type Suffix = String + +splitFilename :: String -> (String,Suffix) +splitFilename f = split_longest_prefix f '.' -remove_suffix :: Char -> String -> String +getFileSuffix :: String -> Suffix +getFileSuffix f = drop_longest_prefix f '.' + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") +splitFilename3 :: String -> (String,String,Suffix) +splitFilename3 str + = let (dir, rest) = split_longest_prefix str '/' + (name, ext) = splitFilename rest + real_dir | null dir = "." + | otherwise = dir + in (real_dir, name, ext) + +remove_suffix :: Char -> String -> Suffix remove_suffix c s | null pre = reverse suf | otherwise = reverse pre @@ -150,7 +159,17 @@ take_longest_prefix :: String -> Char -> String take_longest_prefix s c = reverse pre where (_suf,pre) = break (==c) (reverse s) -newsuf :: String -> String -> String +-- split a string at the last occurence of 'c', returning the two +-- parts of the string with the 'c' removed. If the string contains +-- no 'c's, the entire string is returned in the second component. +split_longest_prefix :: String -> Char -> (String,String) +split_longest_prefix s c + = case pre of + [] -> ([], reverse suf) + (_:pre) -> (reverse pre, reverse suf) + where (suf,pre) = break (==c) (reverse s) + +newsuf :: String -> Suffix -> String newsuf suf s = remove_suffix '.' s ++ suf -- getdir strips the filename off the input string, returning the directory. @@ -163,3 +182,5 @@ newdir dir s = dir ++ '/':drop_longest_prefix s '/' remove_spaces :: String -> String remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +