ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.21 2001/05/08 10:58:48 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
  18 import IOExts
  19 import Exception
  20 import Dynamic
  21 import RegexString
  22
  23 import Directory        ( getDirectoryContents )
  24 import IO
  25 import System
  26 import List
  27 import Char
  28 import Monad
  29
  30 -----------------------------------------------------------------------------
  31 -- Errors
  32
  33 GLOBAL_VAR(v_Path_usage,  "",  String)
  34
  35 long_usage = do
  36   usage_path <- readIORef v_Path_usage
  37   usage <- readFile usage_path
  38   dump usage
  39   exitWith ExitSuccess
  40   where
  41      dump "" = return ()
  42      dump ('$':'$':s) = hPutStr stderr progName >> dump s
  43      dump (c:s) = hPutChar stderr c >> dump s
  44
  45 -----------------------------------------------------------------------------
  46 -- Reading OPTIONS pragmas
  47
  48 getOptionsFromSource
  49         :: String               -- input file
  50         -> IO [String]          -- options, if any
  51 getOptionsFromSource file
  52   = do h <- openFile file ReadMode
  53        catchJust ioErrors (look h)
  54           (\e -> if isEOFError e then return [] else ioError e)
  55   where
  56         look h = do
  57             l <- hGetLine h
  58             case () of
  59                 () | null l -> look h
  60                    | prefixMatch "#" l -> look h
  61                    | prefixMatch "{-# LINE" l -> look h   -- -}
  62                    | Just (opts:_) <- matchRegex optionRegex l
  63                         -> do rest <- look h
  64                               return (words opts ++ rest)
  65                    | otherwise -> return []
  66
  67 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  68
  69 -----------------------------------------------------------------------------
  70 -- A version of getDirectoryContents that is non-fatal if the
  71 -- directory doesn't exist.
  72
  73 softGetDirectoryContents d
  74    = IO.catch (getDirectoryContents d)
  75           (\_ -> do hPutStr stderr
  76                           ("WARNING: error while reading directory " ++ d)
  77                     return []
  78           )
  79
  80 -----------------------------------------------------------------------------
  81 -- Utils
  82
  83 unknownFlagErr :: String -> a
  84 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  85
  86 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  87 my_partition _ [] = ([],[])
  88 my_partition p (a:as)
  89   = let (bs,cs) = my_partition p as in
  90     case p a of
  91         Nothing -> (bs,a:cs)
  92         Just b  -> ((a,b):bs,cs)
  93
  94 my_prefix_match :: String -> String -> Maybe String
  95 my_prefix_match [] rest = Just rest
  96 my_prefix_match (_:_) [] = Nothing
  97 my_prefix_match (p:pat) (r:rest)
  98   | p == r    = my_prefix_match pat rest
  99   | otherwise = Nothing
 100
 101 later = flip finally
 102
 103 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 104 handleDyn = flip catchDyn
 105
 106 handle :: (Exception -> IO a) -> IO a -> IO a
 107 handle = flip Exception.catchAllIO
 108
 109 split :: Char -> String -> [String]
 110 split c s = case rest of
 111                 []     -> [chunk]
 112                 _:rest -> chunk : split c rest
 113   where (chunk, rest) = break (==c) s
 114
 115 add :: IORef [a] -> a -> IO ()
 116 add var x = do
 117   xs <- readIORef var
 118   writeIORef var (x:xs)
 119
 120 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 121 addNoDups var x = do
 122   xs <- readIORef var
 123   unless (x `elem` xs) $ writeIORef var (x:xs)
 124
 125 splitFilename :: String -> (String,String)
 126 splitFilename f = split_longest_prefix f '.'
 127
 128 getFileSuffix :: String -> String
 129 getFileSuffix f = drop_longest_prefix f '.'
 130
 131 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 132 splitFilename3 :: String -> (String,String,String)
 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 -> String
 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 -> String -> 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