ghc/compiler/main/DriverUtil.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverUtil.hs,v 1.19 2001/03/08 09:50: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 "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import Util
  16 import Panic
  17
  18 import IOExts
  19 import Exception
  20 import Dynamic
  21 import RegexString
  22
  23 import IO
  24 import System
  25 import List
  26 import Char
  27 import Monad
  28
  29 -----------------------------------------------------------------------------
  30 -- Errors
  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 progName >> dump s
  42      dump (c:s) = hPutChar stderr c >> dump s
  43
  44 -----------------------------------------------------------------------------
  45 -- Reading OPTIONS pragmas
  46
  47 getOptionsFromSource
  48         :: String               -- input file
  49         -> IO [String]          -- options, if any
  50 getOptionsFromSource file
  51   = do h <- openFile file ReadMode
  52        catchJust ioErrors (look h)
  53           (\e -> if isEOFError e then return [] else ioError e)
  54   where
  55         look h = do
  56             l <- hGetLine h
  57             case () of
  58                 () | null l -> look h
  59                    | prefixMatch "#" l -> look h
  60                    | prefixMatch "{-# LINE" l -> look h   -- -}
  61                    | Just (opts:_) <- matchRegex optionRegex l
  62                         -> do rest <- look h
  63                               return (words opts ++ rest)
  64                    | otherwise -> return []
  65
  66 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
  67
  68 -----------------------------------------------------------------------------
  69 -- Utils
  70
  71 unknownFlagErr :: String -> a
  72 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
  73
  74 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
  75 my_partition _ [] = ([],[])
  76 my_partition p (a:as)
  77   = let (bs,cs) = my_partition p as in
  78     case p a of
  79         Nothing -> (bs,a:cs)
  80         Just b  -> ((a,b):bs,cs)
  81
  82 my_prefix_match :: String -> String -> Maybe String
  83 my_prefix_match [] rest = Just rest
  84 my_prefix_match (_:_) [] = Nothing
  85 my_prefix_match (p:pat) (r:rest)
  86   | p == r    = my_prefix_match pat rest
  87   | otherwise = Nothing
  88
  89 later = flip finally
  90
  91 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
  92 handleDyn = flip catchDyn
  93
  94 handle :: (Exception -> IO a) -> IO a -> IO a
  95 handle = flip Exception.catchAllIO
  96
  97 split :: Char -> String -> [String]
  98 split c s = case rest of
  99                 []     -> [chunk]
 100                 _:rest -> chunk : split c rest
 101   where (chunk, rest) = break (==c) s
 102
 103 add :: IORef [a] -> a -> IO ()
 104 add var x = do
 105   xs <- readIORef var
 106   writeIORef var (x:xs)
 107
 108 addNoDups :: Eq a => IORef [a] -> a -> IO ()
 109 addNoDups var x = do
 110   xs <- readIORef var
 111   unless (x `elem` xs) $ writeIORef var (x:xs)
 112
 113 splitFilename :: String -> (String,String)
 114 splitFilename f = split_longest_prefix f '.'
 115
 116 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 117 splitFilename3 :: String -> (String,String,String)
 118 splitFilename3 str
 119    = let (dir, rest) = split_longest_prefix str '/'
 120          (name, ext) = splitFilename rest
 121          real_dir | null dir  = "."
 122                   | otherwise = dir
 123      in  (real_dir, name, ext)
 124
 125 remove_suffix :: Char -> String -> String
 126 remove_suffix c s
 127   | null pre  = reverse suf
 128   | otherwise = reverse pre
 129   where (suf,pre) = break (==c) (reverse s)
 130
 131 drop_longest_prefix :: String -> Char -> String
 132 drop_longest_prefix s c = reverse suf
 133   where (suf,_pre) = break (==c) (reverse s)
 134
 135 take_longest_prefix :: String -> Char -> String
 136 take_longest_prefix s c = reverse pre
 137   where (_suf,pre) = break (==c) (reverse s)
 138
 139 -- split a string at the last occurence of 'c', returning the two
 140 -- parts of the string with the 'c' removed.  If the string contains
 141 -- no 'c's, the entire string is returned in the second component.
 142 split_longest_prefix :: String -> Char -> (String,String)
 143 split_longest_prefix s c
 144   = case pre of
 145         []      -> ([], reverse suf)
 146         (_:pre) -> (reverse pre, reverse suf)
 147   where (suf,pre) = break (==c) (reverse s)
 148
 149 newsuf :: String -> String -> String
 150 newsuf suf s = remove_suffix '.' s ++ suf
 151
 152 -- getdir strips the filename off the input string, returning the directory.
 153 getdir :: String -> String
 154 getdir s = if null dir then "." else init dir
 155   where dir = take_longest_prefix s '/'
 156
 157 newdir :: String -> String -> String
 158 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 159
 160 remove_spaces :: String -> String
 161 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 162