ghc/compiler/main/DriverUtil.hs

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