ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.30 2002/02/08 14:59:19 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
  23 import Directory        ( getDirectoryContents )
  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 -- Prefixing underscore to linker-level names
  73 prefixUnderscore :: String -> String
  74 prefixUnderscore
  75  | cLeadingUnderscore == "YES" = ('_':)
  76  | otherwise                   = id
  77
  78 -----------------------------------------------------------------------------
  79 -- Utils
  80
  81 unknownFlagErr :: String -> a
  82 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  83
  84 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  85 my_partition _ [] = ([],[])
  86 my_partition p (a:as)
  87   = let (bs,cs) = my_partition p as in
  88     case p a of
  89         Nothing -> (bs,a:cs)
  90         Just b  -> ((a,b):bs,cs)
  91
  92 my_prefix_match :: String -> String -> Maybe String
  93 my_prefix_match []    rest = Just rest
  94 my_prefix_match (_:_) []   = Nothing
  95 my_prefix_match (p:pat) (r:rest)
  96   | p == r    = my_prefix_match pat rest
  97   | otherwise = Nothing
  98
  99 later = flip finally
 100
 101 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 102 handleDyn = flip catchDyn
 103
 104 handle :: (Exception -> IO a) -> IO a -> IO a
 105 #if __GLASGOW_HASKELL__ < 501
 106 handle = flip Exception.catchAllIO
 107 #else
 108 handle h f = f `Exception.catch` \e -> case e of
 109     ExitException _ -> throw e
 110     _               -> h e
 111 #endif
 112
 113 split :: Char -> String -> [String]
 114 split c s = case rest of
 115                 []     -> [chunk]
 116                 _:rest -> chunk : split c rest
 117   where (chunk, rest) = break (==c) s
 118
 119 add :: IORef [a] -> a -> IO ()
 120 add var x = do
 121   xs <- readIORef var
 122   writeIORef var (x:xs)
 123
 124 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 125 addNoDups var x = do
 126   xs <- readIORef var
 127   unless (x `elem` xs) $ writeIORef var (x:xs)
 128
 129 ------------------------------------------------------
 130 --              Filename manipulation
 131 ------------------------------------------------------
 132
 133 type Suffix = String
 134
 135 splitFilename :: String -> (String,Suffix)
 136 splitFilename f = split_longest_prefix f (=='.')
 137
 138 getFileSuffix :: String -> Suffix
 139 getFileSuffix f = drop_longest_prefix f (=='.')
 140
 141 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 142 splitFilename3 :: String -> (String,String,Suffix)
 143 splitFilename3 str
 144    = let (dir, rest) = split_longest_prefix str isPathSeparator
 145          (name, ext) = splitFilename rest
 146          real_dir | null dir  = "."
 147                   | otherwise = dir
 148      in  (real_dir, name, ext)
 149
 150 remove_suffix :: Char -> String -> Suffix
 151 remove_suffix c s
 152   | null pre  = reverse suf
 153   | otherwise = reverse pre
 154   where (suf,pre) = break (==c) (reverse s)
 155
 156 drop_longest_prefix :: String -> (Char -> Bool) -> String
 157 drop_longest_prefix s pred = reverse suf
 158   where (suf,_pre) = break pred (reverse s)
 159
 160 take_longest_prefix :: String -> (Char -> Bool) -> String
 161 take_longest_prefix s pred = reverse pre
 162   where (_suf,pre) = break pred (reverse s)
 163
 164 -- split a string at the last character where 'pred' is True,
 165 -- returning a pair of strings. The first component holds the string
 166 -- up (but not including) the last character for which 'pred' returned
 167 -- True, the second whatever comes after (but also not including the
 168 -- last character).
 169 --
 170 -- If 'pred' returns False for all characters in the string, the original
 171 -- string is returned in the second component (and the first one is just
 172 -- empty).
 173 split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
 174 split_longest_prefix s pred
 175   = case pre of
 176         []      -> ([], reverse suf)
 177         (_:pre) -> (reverse pre, reverse suf)
 178   where (suf,pre) = break pred (reverse s)
 179
 180 newsuf :: String -> Suffix -> String
 181 newsuf suf s = remove_suffix '.' s ++ suf
 182
 183 -- getdir strips the filename off the input string, returning the directory.
 184 getdir :: String -> String
 185 getdir s = if null dir then "." else init dir
 186   where dir = take_longest_prefix s isPathSeparator
 187
 188 newdir :: String -> String -> String
 189 newdir dir s = dir ++ '/':drop_longest_prefix s isPathSeparator
 190
 191 remove_spaces :: String -> String
 192 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 193
 194 isPathSeparator :: Char -> Bool
 195 isPathSeparator ch =
 196 #ifdef mingw32_TARGET_OS
 197   ch == '/' || ch == '\\'
 198 #else
 199   ch == '/'
 200 #endif