ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 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 "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 remove_suffix :: Char -> String -> String
 140 remove_suffix c s
 141   | null pre  = reverse suf
 142   | otherwise = reverse pre
 143   where (suf,pre) = break (==c) (reverse s)
 144
 145 drop_longest_prefix :: String -> Char -> String
 146 drop_longest_prefix s c = reverse suf
 147   where (suf,_pre) = break (==c) (reverse s)
 148
 149 take_longest_prefix :: String -> Char -> String
 150 take_longest_prefix s c = reverse pre
 151   where (_suf,pre) = break (==c) (reverse s)
 152
 153 newsuf :: String -> String -> String
 154 newsuf suf s = remove_suffix '.' s ++ suf
 155
 156 -- getdir strips the filename off the input string, returning the directory.
 157 getdir :: String -> String
 158 getdir s = if null dir then "." else init dir
 159   where dir = take_longest_prefix s '/'
 160
 161 newdir :: String -> String -> String
 162 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 163
 164 remove_spaces :: String -> String
 165 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace