ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 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
  21 import IO
  22 import System
  23 import Directory
  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 long_usage = do
  34   let usage_file = "ghc-usage.txt"
  35       usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
  36   usage <- readFile usage_path
  37   dump usage
  38   exitWith ExitSuccess
  39   where
  40      dump "" = return ()
  41      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
  42      dump (c:s) = hPutChar stderr c >> dump s
  43
  44 version_str = cProjectVersion
  45
  46 data BarfKind
  47   = PhaseFailed String ExitCode
  48   | Interrupted
  49   | UsageError String                   -- prints the short usage msg after the error
  50   | OtherError String                   -- just prints the error message
  51   deriving Eq
  52
  53 GLOBAL_VAR(prog_name, "ghc", String)
  54
  55 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
  56
  57 instance Show BarfKind where
  58   showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
  59
  60 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
  61 showBarf (OtherError str) = showString str
  62 showBarf (PhaseFailed phase code) =
  63         showString phase . showString " failed, code = " . shows code
  64 showBarf (Interrupted) = showString "interrupted"
  65
  66 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  67
  68 barfKindTc = mkTyCon "BarfKind"
  69 instance Typeable BarfKind where
  70   typeOf _ = mkAppTy barfKindTc []
  71
  72 -----------------------------------------------------------------------------
  73 -- Finding files in the installation
  74
  75 GLOBAL_VAR(topDir, clibdir, String)
  76
  77         -- grab the last -B option on the command line, and
  78         -- set topDir to its value.
  79 setTopDir :: [String] -> IO [String]
  80 setTopDir args = do
  81   let (minusbs, others) = partition (prefixMatch "-B") args
  82   (case minusbs of
  83     []   -> writeIORef topDir clibdir
  84     some -> writeIORef topDir (drop 2 (last some)))
  85   return others
  86
  87 findFile name alt_path = unsafePerformIO (do
  88   top_dir <- readIORef topDir
  89   let installed_file = top_dir ++ '/':name
  90   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
  91   b <- doesFileExist inplace_file
  92   if b  then return inplace_file
  93         else return installed_file
  94  )
  95
  96 -----------------------------------------------------------------------------
  97 -- Utils
  98
  99 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
 100 my_partition _ [] = ([],[])
 101 my_partition p (a:as)
 102   = let (bs,cs) = my_partition p as in
 103     case p a of
 104         Nothing -> (bs,a:cs)
 105         Just b  -> ((a,b):bs,cs)
 106
 107 my_prefix_match :: String -> String -> Maybe String
 108 my_prefix_match [] rest = Just rest
 109 my_prefix_match (_:_) [] = Nothing
 110 my_prefix_match (p:pat) (r:rest)
 111   | p == r    = my_prefix_match pat rest
 112   | otherwise = Nothing
 113
 114 prefixMatch :: Eq a => [a] -> [a] -> Bool
 115 prefixMatch [] _str = True
 116 prefixMatch _pat [] = False
 117 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 118                           | otherwise = False
 119
 120 postfixMatch :: String -> String -> Bool
 121 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
 122
 123 later = flip finally
 124
 125 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 126 handleDyn = flip catchDyn
 127
 128 split :: Char -> String -> [String]
 129 split c s = case rest of
 130                 []     -> [chunk]
 131                 _:rest -> chunk : split c rest
 132   where (chunk, rest) = break (==c) s
 133
 134 add :: IORef [a] -> a -> IO ()
 135 add var x = do
 136   xs <- readIORef var
 137   writeIORef var (x:xs)
 138
 139 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 140 addNoDups var x = do
 141   xs <- readIORef var
 142   unless (x `elem` xs) $ writeIORef var (x:xs)
 143
 144 remove_suffix :: Char -> String -> String
 145 remove_suffix c s
 146   | null pre  = reverse suf
 147   | otherwise = reverse pre
 148   where (suf,pre) = break (==c) (reverse s)
 149
 150 drop_longest_prefix :: String -> Char -> String
 151 drop_longest_prefix s c = reverse suf
 152   where (suf,_pre) = break (==c) (reverse s)
 153
 154 take_longest_prefix :: String -> Char -> String
 155 take_longest_prefix s c = reverse pre
 156   where (_suf,pre) = break (==c) (reverse s)
 157
 158 newsuf :: String -> String -> String
 159 newsuf suf s = remove_suffix '.' s ++ suf
 160
 161 -- getdir strips the filename off the input string, returning the directory.
 162 getdir :: String -> String
 163 getdir s = if null dir then "." else init dir
 164   where dir = take_longest_prefix s '/'
 165
 166 newdir :: String -> String -> String
 167 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 168
 169 remove_spaces :: String -> String
 170 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 171
 172 booter_version
 173  = case "\
 174         \ __GLASGOW_HASKELL__" of
 175     ' ':n:ns -> n:'.':ns
 176     ' ':m    -> m
 177