ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.8 2000/11/17 13:33:17 sewardj 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 "HsVersions.h"
  13
  14 import Config
  15 import Util
  16
  17 import IOExts
  18 import Exception
  19 import Dynamic
  20 import RegexString
  21
  22 import IO
  23 import System
  24 import List
  25 import Char
  26 import Monad
  27
  28 -----------------------------------------------------------------------------
  29 -- Errors
  30
  31 short_usage = "Usage: For basic information, try the `--help' option."
  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 get_prog_name >> dump s
  43      dump (c:s) = hPutChar stderr c >> dump s
  44
  45 data BarfKind
  46   = PhaseFailed String ExitCode
  47   | Interrupted
  48   | UsageError String                   -- prints the short usage msg after the error
  49   | OtherError String                   -- just prints the error message
  50   deriving Eq
  51
  52 GLOBAL_VAR(v_Prog_name, "ghc", String)
  53
  54 get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk!
  55
  56 instance Show BarfKind where
  57   showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
  58
  59 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
  60 showBarf (OtherError str) = showString str
  61 showBarf (PhaseFailed phase code) =
  62         showString phase . showString " failed, code = " . shows code
  63 showBarf (Interrupted) = showString "interrupted"
  64
  65 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  66
  67 barfKindTc = mkTyCon "BarfKind"
  68 instance Typeable BarfKind where
  69   typeOf _ = mkAppTy barfKindTc []
  70
  71 -----------------------------------------------------------------------------
  72 -- Reading OPTIONS pragmas
  73
  74 getOptionsFromSource
  75         :: String               -- input file
  76         -> IO [String]          -- options, if any
  77 getOptionsFromSource file
  78   = do h <- openFile file ReadMode
  79        catchJust ioErrors (look h)
  80           (\e -> if isEOFError e then return [] else ioError e)
  81   where
  82         look h = do
  83             l <- hGetLine h
  84             case () of
  85                 () | null l -> look h
  86                    | prefixMatch "#" l -> look h
  87                    | prefixMatch "{-# LINE" l -> look h   -- -}
  88                    | Just (opts:_) <- matchRegex optionRegex l
  89                         -> return (words opts)
  90                    | otherwise -> return []
  91
  92 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  93
  94 -----------------------------------------------------------------------------
  95 -- Utils
  96
  97 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  98 my_partition _ [] = ([],[])
  99 my_partition p (a:as)
 100   = let (bs,cs) = my_partition p as in
 101     case p a of
 102         Nothing -> (bs,a:cs)
 103         Just b  -> ((a,b):bs,cs)
 104
 105 my_prefix_match :: String -> String -> Maybe String
 106 my_prefix_match [] rest = Just rest
 107 my_prefix_match (_:_) [] = Nothing
 108 my_prefix_match (p:pat) (r:rest)
 109   | p == r    = my_prefix_match pat rest
 110   | otherwise = Nothing
 111
 112 later = flip finally
 113
 114 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 115 handleDyn = flip catchDyn
 116
 117 split :: Char -> String -> [String]
 118 split c s = case rest of
 119                 []     -> [chunk]
 120                 _:rest -> chunk : split c rest
 121   where (chunk, rest) = break (==c) s
 122
 123 add :: IORef [a] -> a -> IO ()
 124 add var x = do
 125   xs <- readIORef var
 126   writeIORef var (x:xs)
 127
 128 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 129 addNoDups var x = do
 130   xs <- readIORef var
 131   unless (x `elem` xs) $ writeIORef var (x:xs)
 132
 133 splitFilename :: String -> (String,String)
 134 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
 135   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
 136         stripDot ('.':xs) = xs
 137         stripDot xs       = xs
 138
 139 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 140 splitFilename3 :: String -> (String,String,String)
 141 splitFilename3 str
 142    = let dir = getdir str
 143          (name, ext) = splitFilename (drop (length dir) str)
 144      in  (dir, name, ext)
 145
 146 remove_suffix :: Char -> String -> String
 147 remove_suffix c s
 148   | null pre  = reverse suf
 149   | otherwise = reverse pre
 150   where (suf,pre) = break (==c) (reverse s)
 151
 152 drop_longest_prefix :: String -> Char -> String
 153 drop_longest_prefix s c = reverse suf
 154   where (suf,_pre) = break (==c) (reverse s)
 155
 156 take_longest_prefix :: String -> Char -> String
 157 take_longest_prefix s c = reverse pre
 158   where (_suf,pre) = break (==c) (reverse s)
 159
 160 newsuf :: String -> String -> String
 161 newsuf suf s = remove_suffix '.' s ++ suf
 162
 163 -- getdir strips the filename off the input string, returning the directory.
 164 getdir :: String -> String
 165 getdir s = if null dir then "." else init dir
 166   where dir = take_longest_prefix s '/'
 167
 168 newdir :: String -> String -> String
 169 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 170
 171 remove_spaces :: String -> String
 172 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace