ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.11 2000/11/20 16:28:29 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 Util
  15
  16 import IOExts
  17 import Exception
  18 import Dynamic
  19 import RegexString
  20
  21 import IO
  22 import System
  23 import List
  24 import Char
  25 import Monad
  26
  27 -----------------------------------------------------------------------------
  28 -- Errors
  29
  30 short_usage = "Usage: For basic information, try the `--help' option."
  31
  32 GLOBAL_VAR(v_Path_usage,  "",  String)
  33
  34 long_usage = do
  35   usage_path <- readIORef v_Path_usage
  36   usage <- readFile usage_path
  37   dump usage
  38   exitWith ExitSuccess
  39   where
  40      dump "" = return ()
  41      dump ('$':'$':s) = hPutStr stderr prog_name >> dump s
  42      dump (c:s) = hPutChar stderr c >> dump s
  43
  44 data BarfKind
  45   = PhaseFailed String ExitCode
  46   | Interrupted
  47   | UsageError String                   -- prints the short usage msg after the error
  48   | OtherError String                   -- just prints the error message
  49   deriving Eq
  50
  51 prog_name = unsafePerformIO (getProgName)
  52 {-# NOINLINE prog_name #-}
  53
  54 instance Show BarfKind where
  55   showsPrec _ e = showString prog_name . showString ": " . showBarf e
  56
  57 showBarf (UsageError str)
  58    = showString str . showChar '\n' . showString short_usage
  59 showBarf (OtherError str)
  60    = showString str
  61 showBarf (PhaseFailed phase code)
  62    = showString phase . showString " failed, code = " . shows code
  63 showBarf (Interrupted)
  64    = showString "interrupted"
  65
  66 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  67
  68 barfKindTc = mkTyCon "BarfKind"
  69 {-# NOINLINE barfKindTc #-}
  70 instance Typeable BarfKind where
  71   typeOf _ = mkAppTy barfKindTc []
  72
  73 -----------------------------------------------------------------------------
  74 -- Reading OPTIONS pragmas
  75
  76 getOptionsFromSource
  77         :: String               -- input file
  78         -> IO [String]          -- options, if any
  79 getOptionsFromSource file
  80   = do h <- openFile file ReadMode
  81        catchJust ioErrors (look h)
  82           (\e -> if isEOFError e then return [] else ioError e)
  83   where
  84         look h = do
  85             l <- hGetLine h
  86             case () of
  87                 () | null l -> look h
  88                    | prefixMatch "#" l -> look h
  89                    | prefixMatch "{-# LINE" l -> look h   -- -}
  90                    | Just (opts:_) <- matchRegex optionRegex l
  91                         -> return (words opts)
  92                    | otherwise -> return []
  93
  94 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  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 later = flip finally
 115
 116 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 117 handleDyn = flip catchDyn
 118
 119 split :: Char -> String -> [String]
 120 split c s = case rest of
 121                 []     -> [chunk]
 122                 _:rest -> chunk : split c rest
 123   where (chunk, rest) = break (==c) s
 124
 125 add :: IORef [a] -> a -> IO ()
 126 add var x = do
 127   xs <- readIORef var
 128   writeIORef var (x:xs)
 129
 130 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 131 addNoDups var x = do
 132   xs <- readIORef var
 133   unless (x `elem` xs) $ writeIORef var (x:xs)
 134
 135 splitFilename :: String -> (String,String)
 136 splitFilename f = split_longest_prefix f '.'
 137
 138 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 139 splitFilename3 :: String -> (String,String,String)
 140 splitFilename3 str
 141    = let (dir, rest) = split_longest_prefix str '/'
 142          (name, ext) = splitFilename rest
 143          real_dir | null dir  = "."
 144                   | otherwise = dir
 145      in  (real_dir, name, ext)
 146
 147 remove_suffix :: Char -> String -> String
 148 remove_suffix c s
 149   | null pre  = reverse suf
 150   | otherwise = reverse pre
 151   where (suf,pre) = break (==c) (reverse s)
 152
 153 drop_longest_prefix :: String -> Char -> String
 154 drop_longest_prefix s c = reverse suf
 155   where (suf,_pre) = break (==c) (reverse s)
 156
 157 take_longest_prefix :: String -> Char -> String
 158 take_longest_prefix s c = reverse pre
 159   where (_suf,pre) = break (==c) (reverse s)
 160
 161 -- split a string at the last occurence of 'c', returning the two
 162 -- parts of the string with the 'c' removed.  If the string contains
 163 -- no 'c's, the entire string is returned in the second component.
 164 split_longest_prefix :: String -> Char -> (String,String)
 165 split_longest_prefix s c
 166   = case pre of
 167         []      -> ([], reverse suf)
 168         (_:pre) -> (reverse pre, reverse suf)
 169   where (suf,pre) = break (==c) (reverse s)
 170
 171 newsuf :: String -> String -> String
 172 newsuf suf s = remove_suffix '.' s ++ suf
 173
 174 -- getdir strips the filename off the input string, returning the directory.
 175 getdir :: String -> String
 176 getdir s = if null dir then "." else init dir
 177   where dir = take_longest_prefix s '/'
 178
 179 newdir :: String -> String -> String
 180 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 181
 182 remove_spaces :: String -> String
 183 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace