ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.10 2000/11/20 15:40:54 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 = (reverse (stripDot rev_basename), reverse rev_ext)
 137   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
 138         stripDot ('.':xs) = xs
 139         stripDot xs       = xs
 140
 141 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 142 splitFilename3 :: String -> (String,String,String)
 143 splitFilename3 str
 144    = let (dir, rest) = split_longest_prefix str '/'
 145          (name, ext) = splitFilename rest
 146          real_dir | null dir  = "."
 147                   | otherwise = dir
 148      in  (real_dir, name, ext)
 149
 150 remove_suffix :: Char -> String -> String
 151 remove_suffix c s
 152   | null pre  = reverse suf
 153   | otherwise = reverse pre
 154   where (suf,pre) = break (==c) (reverse s)
 155
 156 drop_longest_prefix :: String -> Char -> String
 157 drop_longest_prefix s c = reverse suf
 158   where (suf,_pre) = break (==c) (reverse s)
 159
 160 take_longest_prefix :: String -> Char -> String
 161 take_longest_prefix s c = reverse pre
 162   where (_suf,pre) = break (==c) (reverse s)
 163
 164 -- split a string at the last occurence of 'c', returning the two
 165 -- parts of the string with the 'c' removed.  If the string contains
 166 -- no 'c's, the entire string is returned in the second component.
 167 split_longest_prefix :: String -> Char -> (String,String)
 168 split_longest_prefix s c
 169   = case pre of
 170         []      -> ([], reverse suf)
 171         (_:pre) -> (reverse pre, reverse suf)
 172   where (suf,pre) = break (==c) (reverse s)
 173
 174 newsuf :: String -> String -> String
 175 newsuf suf s = remove_suffix '.' s ++ suf
 176
 177 -- getdir strips the filename off the input string, returning the directory.
 178 getdir :: String -> String
 179 getdir s = if null dir then "." else init dir
 180   where dir = take_longest_prefix s '/'
 181
 182 newdir :: String -> String -> String
 183 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 184
 185 remove_spaces :: String -> String
 186 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace