ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.34 2002/09/13 15:02:34 simonpj Exp $
   3 --
   4 -- Utils for the driver
   5 --
   6 -- (c) The University of Glasgow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverUtil where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import Util
  16 import Panic
  17 import Config           ( cLeadingUnderscore )
  18
  19 import EXCEPTION as Exception
  20 import DYNAMIC
  21 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  22
  23 import Directory        ( getDirectoryContents, doesDirectoryExist )
  24 import IO
  25 import List
  26 import Char
  27 import Monad
  28
  29 -----------------------------------------------------------------------------
  30 -- Reading OPTIONS pragmas
  31
  32 getOptionsFromSource
  33         :: String               -- input file
  34         -> IO [String]          -- options, if any
  35 getOptionsFromSource file
  36   = do h <- openFile file ReadMode
  37        catchJust ioErrors (look h `finally` hClose h)
  38           (\e -> if isEOFError e then return [] else ioError e)
  39   where
  40         look h = do
  41             l' <- hGetLine h
  42             let l = remove_spaces l'
  43             case () of
  44                 () | null l -> look h
  45                    | prefixMatch "#" l -> look h
  46                    | prefixMatch "{-# LINE" l -> look h   -- -}
  47                    | Just opts <- matchOptions l
  48                         -> do rest <- look h
  49                               return (words opts ++ rest)
  50                    | otherwise -> return []
  51
  52 matchOptions s
  53   | Just s1 <- my_prefix_match "{-#" s,
  54     Just s2 <- my_prefix_match "OPTIONS" (remove_spaces s1),
  55     Just s3 <- my_prefix_match "}-#" (reverse s2)
  56   = Just (reverse s3)
  57   | otherwise
  58   = Nothing
  59
  60 -----------------------------------------------------------------------------
  61 -- A version of getDirectoryContents that is non-fatal if the
  62 -- directory doesn't exist.
  63
  64 softGetDirectoryContents d
  65    = IO.catch (getDirectoryContents d)
  66           (\_ -> do hPutStrLn stderr
  67                           ("WARNING: error while reading directory " ++ d)
  68                     return []
  69           )
  70
  71 -----------------------------------------------------------------------------
  72 -- Verify that the 'dirname' portion of a FilePath exists.
  73 --
  74 doesDirNameExist :: FilePath -> IO Bool
  75 doesDirNameExist fpath = doesDirectoryExist (getdir fpath)
  76
  77
  78 -----------------------------------------------------------------------------
  79 -- Prefixing underscore to linker-level names
  80 prefixUnderscore :: String -> String
  81 prefixUnderscore
  82  | cLeadingUnderscore == "YES" = ('_':)
  83  | otherwise                   = id
  84
  85 -----------------------------------------------------------------------------
  86 -- Utils
  87
  88 unknownFlagErr :: String -> a
  89 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  90
  91 unknownFlagsErr :: [String] -> a
  92 unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))
  93
  94 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  95 my_partition _ [] = ([],[])
  96 my_partition p (a:as)
  97   = let (bs,cs) = my_partition p as in
  98     case p a of
  99         Nothing -> (bs,a:cs)
 100         Just b  -> ((a,b):bs,cs)
 101
 102 my_prefix_match :: String -> String -> Maybe String
 103 my_prefix_match []    rest = Just rest
 104 my_prefix_match (_:_) []   = Nothing
 105 my_prefix_match (p:pat) (r:rest)
 106   | p == r    = my_prefix_match pat rest
 107   | otherwise = Nothing
 108
 109 later = flip finally
 110
 111 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 112 handleDyn = flip catchDyn
 113
 114 handle :: (Exception -> IO a) -> IO a -> IO a
 115 #if __GLASGOW_HASKELL__ < 501
 116 handle = flip Exception.catchAllIO
 117 #else
 118 handle h f = f `Exception.catch` \e -> case e of
 119     ExitException _ -> throw e
 120     _               -> h e
 121 #endif
 122
 123 split :: Char -> String -> [String]
 124 split c s = case rest of
 125                 []     -> [chunk]
 126                 _:rest -> chunk : split c rest
 127   where (chunk, rest) = break (==c) s
 128
 129 add :: IORef [a] -> a -> IO ()
 130 add var x = do
 131   xs <- readIORef var
 132   writeIORef var (x:xs)
 133
 134 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 135 addNoDups var x = do
 136   xs <- readIORef var
 137   unless (x `elem` xs) $ writeIORef var (x:xs)
 138
 139 ------------------------------------------------------
 140 --              Filename manipulation
 141 ------------------------------------------------------
 142
 143 type Suffix = String
 144
 145 splitFilename :: String -> (String,Suffix)
 146 splitFilename f = split_longest_prefix f (=='.')
 147
 148 getFileSuffix :: String -> Suffix
 149 getFileSuffix f = drop_longest_prefix f (=='.')
 150
 151 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 152 splitFilename3 :: String -> (String,String,Suffix)
 153 splitFilename3 str
 154    = let (dir, rest) = split_longest_prefix str isPathSeparator
 155          (name, ext) = splitFilename rest
 156          real_dir | null dir  = "."
 157                   | otherwise = dir
 158      in  (real_dir, name, ext)
 159
 160 remove_suffix :: Char -> String -> Suffix
 161 remove_suffix c s
 162   | null pre  = reverse suf
 163   | otherwise = reverse pre
 164   where (suf,pre) = break (==c) (reverse s)
 165
 166 drop_longest_prefix :: String -> (Char -> Bool) -> String
 167 drop_longest_prefix s pred = reverse suf
 168   where (suf,_pre) = break pred (reverse s)
 169
 170 take_longest_prefix :: String -> (Char -> Bool) -> String
 171 take_longest_prefix s pred = reverse pre
 172   where (_suf,pre) = break pred (reverse s)
 173
 174 -- split a string at the last character where 'pred' is True,
 175 -- returning a pair of strings. The first component holds the string
 176 -- up (but not including) the last character for which 'pred' returned
 177 -- True, the second whatever comes after (but also not including the
 178 -- last character).
 179 --
 180 -- If 'pred' returns False for all characters in the string, the original
 181 -- string is returned in the second component (and the first one is just
 182 -- empty).
 183 split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
 184 split_longest_prefix s pred
 185   = case pre of
 186         []      -> ([], reverse suf)
 187         (_:pre) -> (reverse pre, reverse suf)
 188   where (suf,pre) = break pred (reverse s)
 189
 190 newsuf :: String -> Suffix -> String
 191 newsuf suf s = remove_suffix '.' s ++ suf
 192
 193 -- getdir strips the filename off the input string, returning the directory.
 194 getdir :: String -> String
 195 getdir s = if null dir then "." else init dir
 196   where dir = take_longest_prefix s isPathSeparator
 197
 198 newdir :: String -> String -> String
 199 newdir dir s = dir ++ '/':drop_longest_prefix s isPathSeparator
 200
 201 remove_spaces :: String -> String
 202 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 203
 204 escapeSpaces :: String -> String
 205 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 206
 207 isPathSeparator :: Char -> Bool
 208 isPathSeparator ch =
 209 #ifdef mingw32_TARGET_OS
 210   ch == '/' || ch == '\\'
 211 #else
 212   ch == '/'
 213 #endif