ghc/compiler/main/DriverUtil.hs

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