ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.9 2000/11/19 19:40:08 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 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 prog_name >> dump s
  43      dump (c:s) = hPutChar stderr c >> dump s
  44
  45 data BarfKind
  46   = PhaseFailed String ExitCode
  47   | Interrupted
  48   | UsageError String                   -- prints the short usage msg after the error
  49   | OtherError String                   -- just prints the error message
  50   deriving Eq
  51
  52 prog_name = unsafePerformIO (getProgName)
  53 {-# NOINLINE prog_name #-}
  54
  55 instance Show BarfKind where
  56   showsPrec _ e = showString prog_name . showString ": " . showBarf e
  57
  58 showBarf (UsageError str)
  59    = showString str . showChar '\n' . showString short_usage
  60 showBarf (OtherError str)
  61    = showString str
  62 showBarf (PhaseFailed phase code)
  63    = showString phase . showString " failed, code = " . shows code
  64 showBarf (Interrupted)
  65    = showString "interrupted"
  66
  67 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  68
  69 barfKindTc = mkTyCon "BarfKind"
  70 {-# NOINLINE barfKindTc #-}
  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 splitFilename :: String -> (String,String)
 137 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
 138   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
 139         stripDot ('.':xs) = xs
 140         stripDot xs       = xs
 141
 142 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 143 splitFilename3 :: String -> (String,String,String)
 144 splitFilename3 str
 145    = let dir = getdir str
 146          (name, ext) = splitFilename (drop (length dir) str)
 147      in  (dir, name, ext)
 148
 149 remove_suffix :: Char -> String -> String
 150 remove_suffix c s
 151   | null pre  = reverse suf
 152   | otherwise = reverse pre
 153   where (suf,pre) = break (==c) (reverse s)
 154
 155 drop_longest_prefix :: String -> Char -> String
 156 drop_longest_prefix s c = reverse suf
 157   where (suf,_pre) = break (==c) (reverse s)
 158
 159 take_longest_prefix :: String -> Char -> String
 160 take_longest_prefix s c = reverse pre
 161   where (_suf,pre) = break (==c) (reverse s)
 162
 163 newsuf :: String -> String -> String
 164 newsuf suf s = remove_suffix '.' s ++ suf
 165
 166 -- getdir strips the filename off the input string, returning the directory.
 167 getdir :: String -> String
 168 getdir s = if null dir then "." else init dir
 169   where dir = take_longest_prefix s '/'
 170
 171 newdir :: String -> String -> String
 172 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 173
 174 remove_spaces :: String -> String
 175 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace