ghc/compiler/main/DriverUtil.hs

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