ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.3 2000/10/11 15:26:18 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(path_usage,  "",  String)
  34
  35 long_usage = do
  36   usage_path <- readIORef path_usage
  37   usage <- readFile usage_path
  38   dump usage
  39   exitWith ExitSuccess
  40   where
  41      dump "" = return ()
  42      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
  43      dump (c:s) = hPutChar stderr c >> dump s
  44
  45 version_str = cProjectVersion
  46
  47 data BarfKind
  48   = PhaseFailed String ExitCode
  49   | Interrupted
  50   | UsageError String                   -- prints the short usage msg after the error
  51   | OtherError String                   -- just prints the error message
  52   deriving Eq
  53
  54 GLOBAL_VAR(prog_name, "ghc", String)
  55
  56 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
  57
  58 instance Show BarfKind where
  59   showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
  60
  61 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
  62 showBarf (OtherError str) = showString str
  63 showBarf (PhaseFailed phase code) =
  64         showString phase . showString " failed, code = " . shows code
  65 showBarf (Interrupted) = showString "interrupted"
  66
  67 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  68
  69 barfKindTc = mkTyCon "BarfKind"
  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 remove_suffix :: Char -> String -> String
 142 remove_suffix c s
 143   | null pre  = reverse suf
 144   | otherwise = reverse pre
 145   where (suf,pre) = break (==c) (reverse s)
 146
 147 drop_longest_prefix :: String -> Char -> String
 148 drop_longest_prefix s c = reverse suf
 149   where (suf,_pre) = break (==c) (reverse s)
 150
 151 take_longest_prefix :: String -> Char -> String
 152 take_longest_prefix s c = reverse pre
 153   where (_suf,pre) = break (==c) (reverse s)
 154
 155 newsuf :: String -> String -> String
 156 newsuf suf s = remove_suffix '.' s ++ suf
 157
 158 -- getdir strips the filename off the input string, returning the directory.
 159 getdir :: String -> String
 160 getdir s = if null dir then "." else init dir
 161   where dir = take_longest_prefix s '/'
 162
 163 newdir :: String -> String -> String
 164 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 165
 166 remove_spaces :: String -> String
 167 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 168
 169 booter_version
 170  = case "\
 171         \ __GLASGOW_HASKELL__" of
 172     ' ':n:ns -> n:'.':ns
 173     ' ':m    -> m
 174