ghc/compiler/main/DriverUtil.hs

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