ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.22 2001/05/28 03:31:19 sof Exp $
   3 --
   4 -- Utils for the driver
   5 --
   6 -- (c) The University of Glasgow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverUtil where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import Util
  16 import Panic
  17
  18 import IOExts
  19 import Exception
  20 import Dynamic
  21 import RegexString
  22
  23 import Directory        ( getDirectoryContents )
  24 import IO
  25 import System
  26 import List
  27 import Char
  28 import Monad
  29
  30 #ifndef mingw32_TARGET_OS
  31 import Posix
  32 #endif
  33
  34 -----------------------------------------------------------------------------
  35 -- Errors
  36
  37 GLOBAL_VAR(v_Path_usage,  "",  String)
  38
  39 long_usage = do
  40   usage_path <- readIORef v_Path_usage
  41   usage <- readFile usage_path
  42   dump usage
  43   exitWith ExitSuccess
  44   where
  45      dump "" = return ()
  46      dump ('$':'$':s) = hPutStr stderr progName >> dump s
  47      dump (c:s) = hPutChar stderr c >> dump s
  48
  49 -----------------------------------------------------------------------------
  50 -- Reading OPTIONS pragmas
  51
  52 getOptionsFromSource
  53         :: String               -- input file
  54         -> IO [String]          -- options, if any
  55 getOptionsFromSource file
  56   = do h <- openFile file ReadMode
  57        catchJust ioErrors (look h)
  58           (\e -> if isEOFError e then return [] else ioError e)
  59   where
  60         look h = do
  61             l <- hGetLine h
  62             case () of
  63                 () | null l -> look h
  64                    | prefixMatch "#" l -> look h
  65                    | prefixMatch "{-# LINE" l -> look h   -- -}
  66                    | Just (opts:_) <- matchRegex optionRegex l
  67                         -> do rest <- look h
  68                               return (words opts ++ rest)
  69                    | otherwise -> return []
  70
  71 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  72
  73 -----------------------------------------------------------------------------
  74 -- A version of getDirectoryContents that is non-fatal if the
  75 -- directory doesn't exist.
  76
  77 softGetDirectoryContents d
  78    = IO.catch (getDirectoryContents d)
  79           (\_ -> do hPutStr stderr
  80                           ("WARNING: error while reading directory " ++ d)
  81                     return []
  82           )
  83
  84 -----------------------------------------------------------------------------
  85 -- Utils
  86
  87 unknownFlagErr :: String -> a
  88 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  89
  90 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  91 my_partition _ [] = ([],[])
  92 my_partition p (a:as)
  93   = let (bs,cs) = my_partition p as in
  94     case p a of
  95         Nothing -> (bs,a:cs)
  96         Just b  -> ((a,b):bs,cs)
  97
  98 my_prefix_match :: String -> String -> Maybe String
  99 my_prefix_match [] rest = Just rest
 100 my_prefix_match (_:_) [] = Nothing
 101 my_prefix_match (p:pat) (r:rest)
 102   | p == r    = my_prefix_match pat rest
 103   | otherwise = Nothing
 104
 105 later = flip finally
 106
 107 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 108 handleDyn = flip catchDyn
 109
 110 handle :: (Exception -> IO a) -> IO a -> IO a
 111 handle = flip Exception.catchAllIO
 112
 113 split :: Char -> String -> [String]
 114 split c s = case rest of
 115                 []     -> [chunk]
 116                 _:rest -> chunk : split c rest
 117   where (chunk, rest) = break (==c) s
 118
 119 add :: IORef [a] -> a -> IO ()
 120 add var x = do
 121   xs <- readIORef var
 122   writeIORef var (x:xs)
 123
 124 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 125 addNoDups var x = do
 126   xs <- readIORef var
 127   unless (x `elem` xs) $ writeIORef var (x:xs)
 128
 129 splitFilename :: String -> (String,String)
 130 splitFilename f = split_longest_prefix f '.'
 131
 132 getFileSuffix :: String -> String
 133 getFileSuffix f = drop_longest_prefix f '.'
 134
 135 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 136 splitFilename3 :: String -> (String,String,String)
 137 splitFilename3 str
 138    = let (dir, rest) = split_longest_prefix str '/'
 139          (name, ext) = splitFilename rest
 140          real_dir | null dir  = "."
 141                   | otherwise = dir
 142      in  (real_dir, name, ext)
 143
 144 remove_suffix :: Char -> String -> String
 145 remove_suffix c s
 146   | null pre  = reverse suf
 147   | otherwise = reverse pre
 148   where (suf,pre) = break (==c) (reverse s)
 149
 150 drop_longest_prefix :: String -> Char -> String
 151 drop_longest_prefix s c = reverse suf
 152   where (suf,_pre) = break (==c) (reverse s)
 153
 154 take_longest_prefix :: String -> Char -> String
 155 take_longest_prefix s c = reverse pre
 156   where (_suf,pre) = break (==c) (reverse s)
 157
 158 -- split a string at the last occurence of 'c', returning the two
 159 -- parts of the string with the 'c' removed.  If the string contains
 160 -- no 'c's, the entire string is returned in the second component.
 161 split_longest_prefix :: String -> Char -> (String,String)
 162 split_longest_prefix s c
 163   = case pre of
 164         []      -> ([], reverse suf)
 165         (_:pre) -> (reverse pre, reverse suf)
 166   where (suf,pre) = break (==c) (reverse s)
 167
 168 newsuf :: String -> String -> String
 169 newsuf suf s = remove_suffix '.' s ++ suf
 170
 171 -- getdir strips the filename off the input string, returning the directory.
 172 getdir :: String -> String
 173 getdir s = if null dir then "." else init dir
 174   where dir = take_longest_prefix s '/'
 175
 176 newdir :: String -> String -> String
 177 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 178
 179 remove_spaces :: String -> String
 180 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 181
 182
 183 ghcToolDir :: String
 184 prependToolDir :: String -> IO String
 185 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 186 ghcToolDir = unsafePerformIO $ do
 187                 bs <- getEnv "GHC_TOOLDIR" `IO.catch` (\ _ -> return "")
 188                 case bs of
 189                   "" -> return bs
 190                   ls ->
 191                     let
 192                      term = last ls
 193                      bs'
 194                       | term `elem` ['/', '\\'] = bs
 195                       | otherwise = bs ++ ['/']
 196                     in
 197                     return bs'
 198
 199 prependToolDir x = return (dosifyPath (ghcToolDir ++ x))
 200 #else
 201 ghcToolDir = ""
 202 prependToolDir x = return x
 203 #endif
 204
 205 appendInstallDir :: String -> IO String
 206 appendInstallDir cmd =
 207   case ghcToolDir of
 208     "" -> return cmd
 209     _  -> return (unwords [cmd, '-':'B':ghcToolDir])
 210
 211 -- convert filepath into MSDOS form.
 212 dosifyPath :: String -> String
 213 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 214 dosifyPath stuff = subst '/' '\\' real_stuff
 215  where
 216    -- fully convince myself that /cygdrive/ prefixes cannot
 217    -- really appear here.
 218   cygdrive_prefix = "/cygdrive/"
 219
 220   real_stuff
 221     | "/cygdrive/" `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 222     | otherwise = stuff
 223
 224   subst a b ls = map (\ x -> if x == a then b else x) ls
 225 #else
 226 dosifyPath x = x
 227 #endif
 228
 229 #ifdef mingw32_TARGET_OS
 230 foreign import "_getpid" myGetProcessID :: IO Int
 231 #else
 232 myGetProcessID :: IO Int
 233 myGetProcessID = Posix.getProcessID
 234 #endif