ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.38 2003/06/04 15:47:59 simonmar 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 import Config           ( cLeadingUnderscore )
  18
  19 import EXCEPTION        ( Exception(..), finally, throwDyn, catchDyn, throw )
  20 import qualified EXCEPTION as Exception
  21 import DYNAMIC
  22 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  23
  24 import Directory
  25 import IO
  26 import List
  27 import Char
  28 import Monad
  29
  30 -----------------------------------------------------------------------------
  31 -- Reading OPTIONS pragmas
  32
  33 getOptionsFromSource
  34         :: String               -- input file
  35         -> IO [String]          -- options, if any
  36 getOptionsFromSource file
  37   = do h <- openFile file ReadMode
  38        catchJust ioErrors (look h `finally` hClose h)
  39           (\e -> if isEOFError e then return [] else ioError e)
  40   where
  41         look h = do
  42             l' <- hGetLine h
  43             let l = remove_spaces l'
  44             case () of
  45                 () | null l -> look h
  46                    | prefixMatch "#" l -> look h
  47                    | prefixMatch "{-# LINE" l -> look h   -- -}
  48                    | Just opts <- matchOptions l
  49                         -> do rest <- look h
  50                               return (words opts ++ rest)
  51                    | otherwise -> return []
  52
  53 matchOptions s
  54   | Just s1 <- my_prefix_match "{-#" s, -- -}
  55     Just s2 <- my_prefix_match "OPTIONS" (remove_spaces s1),
  56     Just s3 <- my_prefix_match "}-#" (reverse s2)
  57   = Just (reverse s3)
  58   | otherwise
  59   = Nothing
  60
  61 -----------------------------------------------------------------------------
  62 -- A version of getDirectoryContents that is non-fatal if the
  63 -- directory doesn't exist.
  64
  65 softGetDirectoryContents d
  66    = IO.catch (getDirectoryContents d)
  67           (\_ -> do hPutStrLn stderr
  68                           ("WARNING: error while reading directory " ++ d)
  69                     return []
  70           )
  71
  72 -----------------------------------------------------------------------------
  73 -- Create a hierarchy of directories
  74
  75 createDirectoryHierarchy :: FilePath -> IO ()
  76 createDirectoryHierarchy dir = do
  77   b <- doesDirectoryExist dir
  78   when (not b) $ do
  79         createDirectoryHierarchy (directoryOf dir)
  80         createDirectory dir
  81
  82 -----------------------------------------------------------------------------
  83 -- Verify that the 'dirname' portion of a FilePath exists.
  84 --
  85 doesDirNameExist :: FilePath -> IO Bool
  86 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
  87
  88 -----------------------------------------------------------------------------
  89 -- Prefixing underscore to linker-level names
  90 prefixUnderscore :: String -> String
  91 prefixUnderscore
  92  | cLeadingUnderscore == "YES" = ('_':)
  93  | otherwise                   = id
  94
  95 -----------------------------------------------------------------------------
  96 -- Utils
  97
  98 unknownFlagErr :: String -> a
  99 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
 100
 101 unknownFlagsErr :: [String] -> a
 102 unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))
 103
 104 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
 105 my_partition _ [] = ([],[])
 106 my_partition p (a:as)
 107   = let (bs,cs) = my_partition p as in
 108     case p a of
 109         Nothing -> (bs,a:cs)
 110         Just b  -> ((a,b):bs,cs)
 111
 112 my_prefix_match :: String -> String -> Maybe String
 113 my_prefix_match []    rest = Just rest
 114 my_prefix_match (_:_) []   = Nothing
 115 my_prefix_match (p:pat) (r:rest)
 116   | p == r    = my_prefix_match pat rest
 117   | otherwise = Nothing
 118
 119 later = flip finally
 120
 121 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 122 handleDyn = flip catchDyn
 123
 124 handle :: (Exception -> IO a) -> IO a -> IO a
 125 #if __GLASGOW_HASKELL__ < 501
 126 handle = flip Exception.catchAllIO
 127 #else
 128 handle h f = f `Exception.catch` \e -> case e of
 129     ExitException _ -> throw e
 130     _               -> h e
 131 #endif
 132
 133 split :: Char -> String -> [String]
 134 split c s = case rest of
 135                 []     -> [chunk]
 136                 _:rest -> chunk : split c rest
 137   where (chunk, rest) = break (==c) s
 138
 139 add :: IORef [a] -> a -> IO ()
 140 add var x = do
 141   xs <- readIORef var
 142   writeIORef var (x:xs)
 143
 144 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 145 addNoDups var x = do
 146   xs <- readIORef var
 147   unless (x `elem` xs) $ writeIORef var (x:xs)
 148
 149 ------------------------------------------------------
 150 --              Filename manipulation
 151 ------------------------------------------------------
 152
 153 type Suffix = String
 154
 155 splitFilename :: String -> (String,Suffix)
 156 splitFilename f = split_longest_prefix f (=='.')
 157
 158 getFileSuffix :: String -> Suffix
 159 getFileSuffix f = drop_longest_prefix f (=='.')
 160
 161 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 162 splitFilenameDir :: String -> (String,String)
 163 splitFilenameDir str
 164   = let (dir, rest) = split_longest_prefix str isPathSeparator
 165         real_dir | null dir  = "."
 166                  | otherwise = dir
 167     in  (real_dir, rest)
 168
 169 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 170 splitFilename3 :: String -> (String,String,Suffix)
 171 splitFilename3 str
 172    = let (dir, rest) = split_longest_prefix str isPathSeparator
 173          (name, ext) = splitFilename rest
 174          real_dir | null dir  = "."
 175                   | otherwise = dir
 176      in  (real_dir, name, ext)
 177
 178 remove_suffix :: Char -> String -> Suffix
 179 remove_suffix c s
 180   | null pre  = reverse suf
 181   | otherwise = reverse pre
 182   where (suf,pre) = break (==c) (reverse s)
 183
 184 drop_longest_prefix :: String -> (Char -> Bool) -> String
 185 drop_longest_prefix s pred = reverse suf
 186   where (suf,_pre) = break pred (reverse s)
 187
 188 take_longest_prefix :: String -> (Char -> Bool) -> String
 189 take_longest_prefix s pred = reverse pre
 190   where (_suf,pre) = break pred (reverse s)
 191
 192 -- split a string at the last character where 'pred' is True,
 193 -- returning a pair of strings. The first component holds the string
 194 -- up (but not including) the last character for which 'pred' returned
 195 -- True, the second whatever comes after (but also not including the
 196 -- last character).
 197 --
 198 -- If 'pred' returns False for all characters in the string, the original
 199 -- string is returned in the second component (and the first one is just
 200 -- empty).
 201 split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
 202 split_longest_prefix s pred
 203   = case pre of
 204         []      -> ([], reverse suf)
 205         (_:pre) -> (reverse pre, reverse suf)
 206   where (suf,pre) = break pred (reverse s)
 207
 208 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 209 replaceFilenameSuffix s suf = remove_suffix '.' s ++ suf
 210
 211 -- directoryOf strips the filename off the input string, returning
 212 -- the directory.
 213 directoryOf :: FilePath -> String
 214 directoryOf = fst . splitFilenameDir
 215
 216 replaceFilenameDirectory :: FilePath -> String -> FilePath
 217 replaceFilenameDirectory s dir
 218  = dir ++ '/':drop_longest_prefix s isPathSeparator
 219
 220 remove_spaces :: String -> String
 221 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 222
 223 escapeSpaces :: String -> String
 224 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 225
 226 isPathSeparator :: Char -> Bool
 227 isPathSeparator ch =
 228 #ifdef mingw32_TARGET_OS
 229   ch == '/' || ch == '\\'
 230 #else
 231   ch == '/'
 232 #endif