ghc/compiler/main/DriverUtil.hs

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