ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.26 2001/07/23 20:19:53 sof 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             case () of
  48                 () | null l -> look h
  49                    | prefixMatch "#" l -> look h
  50                    | prefixMatch "{-# LINE" l -> look h   -- -}
  51                    | Just (opts:_) <- matchRegex optionRegex l
  52                         -> do rest <- look h
  53                               return (words opts ++ rest)
  54                    | otherwise -> return []
  55
  56 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  57
  58 -----------------------------------------------------------------------------
  59 -- A version of getDirectoryContents that is non-fatal if the
  60 -- directory doesn't exist.
  61
  62 softGetDirectoryContents d
  63    = IO.catch (getDirectoryContents d)
  64           (\_ -> do hPutStr stderr
  65                           ("WARNING: error while reading directory " ++ d)
  66                     return []
  67           )
  68
  69 -----------------------------------------------------------------------------
  70 -- Prefixing underscore to linker-level names
  71 prefixUnderscore :: String -> String
  72 prefixUnderscore
  73  | cLeadingUnderscore == "YES" = ('_':)
  74  | otherwise                   = id
  75
  76 -----------------------------------------------------------------------------
  77 -- Utils
  78
  79 unknownFlagErr :: String -> a
  80 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  81
  82 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  83 my_partition _ [] = ([],[])
  84 my_partition p (a:as)
  85   = let (bs,cs) = my_partition p as in
  86     case p a of
  87         Nothing -> (bs,a:cs)
  88         Just b  -> ((a,b):bs,cs)
  89
  90 my_prefix_match :: String -> String -> Maybe String
  91 my_prefix_match []    rest = Just rest
  92 my_prefix_match (_:_) []   = Nothing
  93 my_prefix_match (p:pat) (r:rest)
  94   | p == r    = my_prefix_match pat rest
  95   | otherwise = Nothing
  96
  97 later = flip finally
  98
  99 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 100 handleDyn = flip catchDyn
 101
 102 handle :: (Exception -> IO a) -> IO a -> IO a
 103 #if __GLASGOW_HASKELL__ < 501
 104 handle = flip Exception.catchAllIO
 105 #else
 106 handle h f = f `Exception.catch` \e -> case e of
 107     ExitException _ -> throw e
 108     _               -> h e
 109 #endif
 110
 111 split :: Char -> String -> [String]
 112 split c s = case rest of
 113                 []     -> [chunk]
 114                 _:rest -> chunk : split c rest
 115   where (chunk, rest) = break (==c) s
 116
 117 add :: IORef [a] -> a -> IO ()
 118 add var x = do
 119   xs <- readIORef var
 120   writeIORef var (x:xs)
 121
 122 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 123 addNoDups var x = do
 124   xs <- readIORef var
 125   unless (x `elem` xs) $ writeIORef var (x:xs)
 126
 127 ------------------------------------------------------
 128 --              Filename manipulation
 129 ------------------------------------------------------
 130
 131 type Suffix = String
 132
 133 splitFilename :: String -> (String,Suffix)
 134 splitFilename f = split_longest_prefix f '.'
 135
 136 getFileSuffix :: String -> Suffix
 137 getFileSuffix f = drop_longest_prefix f '.'
 138
 139 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 140 splitFilename3 :: String -> (String,String,Suffix)
 141 splitFilename3 str
 142    = let (dir, rest) = split_longest_prefix str '/'
 143          (name, ext) = splitFilename rest
 144          real_dir | null dir  = "."
 145                   | otherwise = dir
 146      in  (real_dir, name, ext)
 147
 148 remove_suffix :: Char -> String -> Suffix
 149 remove_suffix c s
 150   | null pre  = reverse suf
 151   | otherwise = reverse pre
 152   where (suf,pre) = break (==c) (reverse s)
 153
 154 drop_longest_prefix :: String -> Char -> String
 155 drop_longest_prefix s c = reverse suf
 156   where (suf,_pre) = break (==c) (reverse s)
 157
 158 take_longest_prefix :: String -> Char -> String
 159 take_longest_prefix s c = reverse pre
 160   where (_suf,pre) = break (==c) (reverse s)
 161
 162 -- split a string at the last occurence of 'c', returning the two
 163 -- parts of the string with the 'c' removed.  If the string contains
 164 -- no 'c's, the entire string is returned in the second component.
 165 split_longest_prefix :: String -> Char -> (String,String)
 166 split_longest_prefix s c
 167   = case pre of
 168         []      -> ([], reverse suf)
 169         (_:pre) -> (reverse pre, reverse suf)
 170   where (suf,pre) = break (==c) (reverse s)
 171
 172 newsuf :: String -> Suffix -> String
 173 newsuf suf s = remove_suffix '.' s ++ suf
 174
 175 -- getdir strips the filename off the input string, returning the directory.
 176 getdir :: String -> String
 177 getdir s = if null dir then "." else init dir
 178   where dir = take_longest_prefix s '/'
 179
 180 newdir :: String -> String -> String
 181 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 182
 183 remove_spaces :: String -> String
 184 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 185
 186