ghc/compiler/main/DriverUtil.hs

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