ghc/compiler/main/DriverUtil.hs

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