ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.6 2000/11/10 14:29:21 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 getOptionsFromSource
  74         :: String               -- input file
  75         -> IO [String]          -- options, if any
  76 getOptionsFromSource file
  77   = do h <- openFile file ReadMode
  78        catchJust ioErrors (look h)
  79           (\e -> if isEOFError e then return [] else ioError e)
  80   where
  81         look h = do
  82             l <- hGetLine h
  83             case () of
  84                 () | null l -> look h
  85                    | prefixMatch "#" l -> look h
  86                    | prefixMatch "{-# LINE" l -> look h   -- -}
  87                    | Just (opts:_) <- matchRegex optionRegex l
  88                         -> return (words opts)
  89                    | otherwise -> return []
  90
  91 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  92
  93 -----------------------------------------------------------------------------
  94 -- Utils
  95
  96 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  97 my_partition _ [] = ([],[])
  98 my_partition p (a:as)
  99   = let (bs,cs) = my_partition p as in
 100     case p a of
 101         Nothing -> (bs,a:cs)
 102         Just b  -> ((a,b):bs,cs)
 103
 104 my_prefix_match :: String -> String -> Maybe String
 105 my_prefix_match [] rest = Just rest
 106 my_prefix_match (_:_) [] = Nothing
 107 my_prefix_match (p:pat) (r:rest)
 108   | p == r    = my_prefix_match pat rest
 109   | otherwise = Nothing
 110
 111 later = flip finally
 112
 113 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 114 handleDyn = flip catchDyn
 115
 116 split :: Char -> String -> [String]
 117 split c s = case rest of
 118                 []     -> [chunk]
 119                 _:rest -> chunk : split c rest
 120   where (chunk, rest) = break (==c) s
 121
 122 add :: IORef [a] -> a -> IO ()
 123 add var x = do
 124   xs <- readIORef var
 125   writeIORef var (x:xs)
 126
 127 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 128 addNoDups var x = do
 129   xs <- readIORef var
 130   unless (x `elem` xs) $ writeIORef var (x:xs)
 131
 132 splitFilename :: String -> (String,String)
 133 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
 134   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
 135         stripDot ('.':xs) = xs
 136         stripDot xs       = xs
 137
 138 remove_suffix :: Char -> String -> String
 139 remove_suffix c s
 140   | null pre  = reverse suf
 141   | otherwise = reverse pre
 142   where (suf,pre) = break (==c) (reverse s)
 143
 144 drop_longest_prefix :: String -> Char -> String
 145 drop_longest_prefix s c = reverse suf
 146   where (suf,_pre) = break (==c) (reverse s)
 147
 148 take_longest_prefix :: String -> Char -> String
 149 take_longest_prefix s c = reverse pre
 150   where (_suf,pre) = break (==c) (reverse s)
 151
 152 newsuf :: String -> String -> String
 153 newsuf suf s = remove_suffix '.' s ++ suf
 154
 155 -- getdir strips the filename off the input string, returning the directory.
 156 getdir :: String -> String
 157 getdir s = if null dir then "." else init dir
 158   where dir = take_longest_prefix s '/'
 159
 160 newdir :: String -> String -> String
 161 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 162
 163 remove_spaces :: String -> String
 164 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace