ghc/compiler/main/DriverUtil.hs

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