ghc/compiler/main/DriverUtil.hs

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