ghc/compiler/main/DriverUtil.hs

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