ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.17 2001/03/06 15:00:25 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 IO
  24 import System
  25 import Directory ( removeFile )
  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 -- Utils
  71
  72 unknownFlagErr :: String -> a
  73 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  74
  75 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  76 my_partition _ [] = ([],[])
  77 my_partition p (a:as)
  78   = let (bs,cs) = my_partition p as in
  79     case p a of
  80         Nothing -> (bs,a:cs)
  81         Just b  -> ((a,b):bs,cs)
  82
  83 my_prefix_match :: String -> String -> Maybe String
  84 my_prefix_match [] rest = Just rest
  85 my_prefix_match (_:_) [] = Nothing
  86 my_prefix_match (p:pat) (r:rest)
  87   | p == r    = my_prefix_match pat rest
  88   | otherwise = Nothing
  89
  90 later = flip finally
  91
  92 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
  93 handleDyn = flip catchDyn
  94
  95 handle :: (Exception -> IO a) -> IO a -> IO a
  96 handle = flip Exception.catchAllIO
  97
  98 split :: Char -> String -> [String]
  99 split c s = case rest of
 100                 []     -> [chunk]
 101                 _:rest -> chunk : split c rest
 102   where (chunk, rest) = break (==c) s
 103
 104 add :: IORef [a] -> a -> IO ()
 105 add var x = do
 106   xs <- readIORef var
 107   writeIORef var (x:xs)
 108
 109 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 110 addNoDups var x = do
 111   xs <- readIORef var
 112   unless (x `elem` xs) $ writeIORef var (x:xs)
 113
 114 splitFilename :: String -> (String,String)
 115 splitFilename f = split_longest_prefix f '.'
 116
 117 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 118 splitFilename3 :: String -> (String,String,String)
 119 splitFilename3 str
 120    = let (dir, rest) = split_longest_prefix str '/'
 121          (name, ext) = splitFilename rest
 122          real_dir | null dir  = "."
 123                   | otherwise = dir
 124      in  (real_dir, name, ext)
 125
 126 remove_suffix :: Char -> String -> String
 127 remove_suffix c s
 128   | null pre  = reverse suf
 129   | otherwise = reverse pre
 130   where (suf,pre) = break (==c) (reverse s)
 131
 132 drop_longest_prefix :: String -> Char -> String
 133 drop_longest_prefix s c = reverse suf
 134   where (suf,_pre) = break (==c) (reverse s)
 135
 136 take_longest_prefix :: String -> Char -> String
 137 take_longest_prefix s c = reverse pre
 138   where (_suf,pre) = break (==c) (reverse s)
 139
 140 -- split a string at the last occurence of 'c', returning the two
 141 -- parts of the string with the 'c' removed.  If the string contains
 142 -- no 'c's, the entire string is returned in the second component.
 143 split_longest_prefix :: String -> Char -> (String,String)
 144 split_longest_prefix s c
 145   = case pre of
 146         []      -> ([], reverse suf)
 147         (_:pre) -> (reverse pre, reverse suf)
 148   where (suf,pre) = break (==c) (reverse s)
 149
 150 newsuf :: String -> String -> String
 151 newsuf suf s = remove_suffix '.' s ++ suf
 152
 153 -- getdir strips the filename off the input string, returning the directory.
 154 getdir :: String -> String
 155 getdir s = if null dir then "." else init dir
 156   where dir = take_longest_prefix s '/'
 157
 158 newdir :: String -> String -> String
 159 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 160
 161 remove_spaces :: String -> String
 162 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 163
 164
 165 -- system that works feasibly under Windows (i.e. passes the command line to sh,
 166 -- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
 167 kludgedSystem cmd phase_name
 168  = do
 169 #ifndef mingw32_TARGET_OS
 170    exit_code <- system cmd `catchAllIO`
 171                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 172 #else
 173    pid <- myGetProcessID
 174    tmp_dir <- readIORef v_TmpDir
 175    let tmp = tmp_dir++"/sh"++show pid
 176    h <- openFile tmp WriteMode
 177    hPutStrLn h cmd
 178    hClose h
 179    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 180                    (\_ -> removeFile tmp >>
 181                           throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 182    removeFile tmp
 183 #endif
 184    return exit_code