ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.23 2001/06/02 09:45:51 qrczak 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 #if __GLASGOW_HASKELL__ < 501
 112 handle = flip Exception.catchAllIO
 113 #else
 114 handle h f = f `Exception.catch` \e -> case e of
 115     ExitException _ -> throw e
 116     _               -> h e
 117 #endif
 118
 119 split :: Char -> String -> [String]
 120 split c s = case rest of
 121                 []     -> [chunk]
 122                 _:rest -> chunk : split c rest
 123   where (chunk, rest) = break (==c) s
 124
 125 add :: IORef [a] -> a -> IO ()
 126 add var x = do
 127   xs <- readIORef var
 128   writeIORef var (x:xs)
 129
 130 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 131 addNoDups var x = do
 132   xs <- readIORef var
 133   unless (x `elem` xs) $ writeIORef var (x:xs)
 134
 135 splitFilename :: String -> (String,String)
 136 splitFilename f = split_longest_prefix f '.'
 137
 138 getFileSuffix :: String -> String
 139 getFileSuffix f = drop_longest_prefix f '.'
 140
 141 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 142 splitFilename3 :: String -> (String,String,String)
 143 splitFilename3 str
 144    = let (dir, rest) = split_longest_prefix str '/'
 145          (name, ext) = splitFilename rest
 146          real_dir | null dir  = "."
 147                   | otherwise = dir
 148      in  (real_dir, name, ext)
 149
 150 remove_suffix :: Char -> String -> String
 151 remove_suffix c s
 152   | null pre  = reverse suf
 153   | otherwise = reverse pre
 154   where (suf,pre) = break (==c) (reverse s)
 155
 156 drop_longest_prefix :: String -> Char -> String
 157 drop_longest_prefix s c = reverse suf
 158   where (suf,_pre) = break (==c) (reverse s)
 159
 160 take_longest_prefix :: String -> Char -> String
 161 take_longest_prefix s c = reverse pre
 162   where (_suf,pre) = break (==c) (reverse s)
 163
 164 -- split a string at the last occurence of 'c', returning the two
 165 -- parts of the string with the 'c' removed.  If the string contains
 166 -- no 'c's, the entire string is returned in the second component.
 167 split_longest_prefix :: String -> Char -> (String,String)
 168 split_longest_prefix s c
 169   = case pre of
 170         []      -> ([], reverse suf)
 171         (_:pre) -> (reverse pre, reverse suf)
 172   where (suf,pre) = break (==c) (reverse s)
 173
 174 newsuf :: String -> String -> String
 175 newsuf suf s = remove_suffix '.' s ++ suf
 176
 177 -- getdir strips the filename off the input string, returning the directory.
 178 getdir :: String -> String
 179 getdir s = if null dir then "." else init dir
 180   where dir = take_longest_prefix s '/'
 181
 182 newdir :: String -> String -> String
 183 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 184
 185 remove_spaces :: String -> String
 186 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 187
 188
 189 ghcToolDir :: String
 190 prependToolDir :: String -> IO String
 191 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 192 ghcToolDir = unsafePerformIO $ do
 193                 bs <- getEnv "GHC_TOOLDIR" `IO.catch` (\ _ -> return "")
 194                 case bs of
 195                   "" -> return bs
 196                   ls ->
 197                     let
 198                      term = last ls
 199                      bs'
 200                       | term `elem` ['/', '\\'] = bs
 201                       | otherwise = bs ++ ['/']
 202                     in
 203                     return bs'
 204
 205 prependToolDir x = return (dosifyPath (ghcToolDir ++ x))
 206 #else
 207 ghcToolDir = ""
 208 prependToolDir x = return x
 209 #endif
 210
 211 appendInstallDir :: String -> IO String
 212 appendInstallDir cmd =
 213   case ghcToolDir of
 214     "" -> return cmd
 215     _  -> return (unwords [cmd, '-':'B':ghcToolDir])
 216
 217 -- convert filepath into MSDOS form.
 218 dosifyPath :: String -> String
 219 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 220 dosifyPath stuff = subst '/' '\\' real_stuff
 221  where
 222    -- fully convince myself that /cygdrive/ prefixes cannot
 223    -- really appear here.
 224   cygdrive_prefix = "/cygdrive/"
 225
 226   real_stuff
 227     | "/cygdrive/" `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 228     | otherwise = stuff
 229
 230   subst a b ls = map (\ x -> if x == a then b else x) ls
 231 #else
 232 dosifyPath x = x
 233 #endif
 234
 235 #ifdef mingw32_TARGET_OS
 236 foreign import "_getpid" myGetProcessID :: IO Int
 237 #else
 238 myGetProcessID :: IO Int
 239 myGetProcessID = Posix.getProcessID
 240 #endif