ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.15 2000/12/12 14:35:08 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 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                         -> return (words opts)
  64                    | otherwise -> return []
  65
  66 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  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 handle = flip Exception.catchAllIO
  96
  97 split :: Char -> String -> [String]
  98 split c s = case rest of
  99                 []     -> [chunk]
 100                 _:rest -> chunk : split c rest
 101   where (chunk, rest) = break (==c) s
 102
 103 add :: IORef [a] -> a -> IO ()
 104 add var x = do
 105   xs <- readIORef var
 106   writeIORef var (x:xs)
 107
 108 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 109 addNoDups var x = do
 110   xs <- readIORef var
 111   unless (x `elem` xs) $ writeIORef var (x:xs)
 112
 113 splitFilename :: String -> (String,String)
 114 splitFilename f = split_longest_prefix f '.'
 115
 116 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 117 splitFilename3 :: String -> (String,String,String)
 118 splitFilename3 str
 119    = let (dir, rest) = split_longest_prefix str '/'
 120          (name, ext) = splitFilename rest
 121          real_dir | null dir  = "."
 122                   | otherwise = dir
 123      in  (real_dir, name, ext)
 124
 125 remove_suffix :: Char -> String -> String
 126 remove_suffix c s
 127   | null pre  = reverse suf
 128   | otherwise = reverse pre
 129   where (suf,pre) = break (==c) (reverse s)
 130
 131 drop_longest_prefix :: String -> Char -> String
 132 drop_longest_prefix s c = reverse suf
 133   where (suf,_pre) = break (==c) (reverse s)
 134
 135 take_longest_prefix :: String -> Char -> String
 136 take_longest_prefix s c = reverse pre
 137   where (_suf,pre) = break (==c) (reverse s)
 138
 139 -- split a string at the last occurence of 'c', returning the two
 140 -- parts of the string with the 'c' removed.  If the string contains
 141 -- no 'c's, the entire string is returned in the second component.
 142 split_longest_prefix :: String -> Char -> (String,String)
 143 split_longest_prefix s c
 144   = case pre of
 145         []      -> ([], reverse suf)
 146         (_:pre) -> (reverse pre, reverse suf)
 147   where (suf,pre) = break (==c) (reverse s)
 148
 149 newsuf :: String -> String -> String
 150 newsuf suf s = remove_suffix '.' s ++ suf
 151
 152 -- getdir strips the filename off the input string, returning the directory.
 153 getdir :: String -> String
 154 getdir s = if null dir then "." else init dir
 155   where dir = take_longest_prefix s '/'
 156
 157 newdir :: String -> String -> String
 158 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 159
 160 remove_spaces :: String -> String
 161 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 162
 163
 164 -- system that works feasibly under Windows (i.e. passes the command line to sh,
 165 -- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
 166 kludgedSystem cmd phase_name
 167  = do
 168 #ifndef mingw32_TARGET_OS
 169    exit_code <- system cmd `catchAllIO`
 170                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 171 #else
 172    pid <- myGetProcessID
 173    let tmp = "/tmp/sh" ++ show pid
 174    h <- openFile tmp WriteMode
 175    hPutStrLn h cmd
 176    hClose h
 177    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 178                    (\_ -> removeFile tmp >>
 179                           throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 180    removeFile tmp
 181 #endif
 182    return exit_code