ghc/compiler/main/DriverUtil.hs

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