1{-# LANGUAGE CPP #-} 2 3------------------------------------------------------------------------ 4-- Program for converting .hsc files to .hs files, by converting the 5-- file into a C program which is run to generate the Haskell source. 6-- Certain items known only to the C compiler can then be used in 7-- the Haskell module; for example #defined constants, byte offsets 8-- within structures, etc. 9-- 10-- See the documentation in the Users' Guide for more details. 11 12import Control.Monad ( liftM, forM_ ) 13import Data.List ( isSuffixOf ) 14import System.Console.GetOpt 15 16-- If we ware building the hsc2hs 17-- binary for binary distribution 18-- in the GHC tree. Obtain 19-- the path to the @$topdir/lib@ 20-- folder, and try to locate the 21-- @template-hsc.h@ there. 22-- 23-- XXX: Note this does not work 24-- on windows due to for 25-- symlinks. See Trac #14483. 26 27#if defined(mingw32_HOST_OS) 28import Foreign 29import Foreign.C.String 30#endif 31import System.Directory ( doesFileExist, findExecutable ) 32import System.Environment ( getProgName ) 33import System.Exit ( ExitCode(..), exitWith ) 34import System.FilePath ( normalise, splitFileName, splitExtension ) 35import System.IO 36 37#ifdef BUILD_NHC 38import System.Directory ( getCurrentDirectory ) 39#else 40import Paths_hsc2hs as Main ( getDataFileName, version ) 41import Data.Version ( showVersion ) 42#endif 43#if defined(IN_GHC_TREE) 44import System.Environment ( getExecutablePath ) 45import System.FilePath ( takeDirectory, (</>) ) 46#endif 47 48import Common 49import Compat.ResponseFile ( getArgsWithResponseFiles ) 50import CrossCodegen 51import DirectCodegen 52import Flags 53import HSCParser 54 55#ifdef mingw32_HOST_OS 56# if defined(i386_HOST_ARCH) 57# define WINDOWS_CCONV stdcall 58# elif defined(x86_64_HOST_ARCH) 59# define WINDOWS_CCONV ccall 60# else 61# error Unknown mingw32 arch 62# endif 63#endif 64 65#ifdef BUILD_NHC 66getDataFileName s = do here <- getCurrentDirectory 67 return (here++"/"++s) 68#endif 69 70versionString :: String 71versionString = "hsc2hs version " ++ showVersion version ++ "\n" 72 73main :: IO () 74main = do 75 prog <- getProgramName 76 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" 77 usage = usageInfo header options 78 args <- getArgsWithResponseFiles 79 let (fs, files, errs) = getOpt Permute options args 80 let mode = foldl (.) id fs emptyMode 81 case mode of 82 Help -> bye usage 83 Version -> bye versionString 84 UseConfig config -> 85 case (files, errs) of 86 ((_:_), []) -> processFiles config files usage 87 (_, _ ) -> die (concat errs ++ usage) 88 89getProgramName :: IO String 90getProgramName = liftM (`withoutSuffix` "-bin") getProgName 91 where str `withoutSuffix` suff 92 | suff `isSuffixOf` str = take (length str - length suff) str 93 | otherwise = str 94 95bye :: String -> IO a 96bye s = putStr s >> exitWith ExitSuccess 97 98processFiles :: ConfigM Maybe -> [FilePath] -> String -> IO () 99processFiles configM files usage = do 100 mb_libdir <- getLibDir 101 102 (template, extraFlags) <- findTemplate usage mb_libdir configM 103 compiler <- findCompiler mb_libdir configM 104 let linker = case cmLinker configM of 105 Nothing -> compiler 106 Just l -> l 107 config = Config { 108 cmTemplate = Id template, 109 cmCompiler = Id compiler, 110 cmLinker = Id linker, 111 cKeepFiles = cKeepFiles configM, 112 cNoCompile = cNoCompile configM, 113 cCrossCompile = cCrossCompile configM, 114 cViaAsm = cViaAsm configM, 115 cCrossSafe = cCrossSafe configM, 116 cColumn = cColumn configM, 117 cVerbose = cVerbose configM, 118 cFlags = cFlags configM ++ extraFlags 119 } 120 121 let outputter = if cCrossCompile config then outputCross else outputDirect 122 123 forM_ files (\name -> do 124 (outName, outDir, outBase) <- case [f | Output f <- cFlags config] of 125 [] -> if not (null ext) && last ext == 'c' 126 then return (dir++base++init ext, dir, base) 127 else 128 if ext == ".hs" 129 then return (dir++base++"_out.hs", dir, base) 130 else return (dir++base++".hs", dir, base) 131 where 132 (dir, file) = splitFileName name 133 (base, ext) = splitExtension file 134 [f] -> let 135 (dir, file) = splitFileName f 136 (base, _) = splitExtension file 137 in return (f, dir, base) 138 _ -> onlyOne "output file" 139 let file_name = normalise name 140 toks <- parseFile file_name 141 outputter config outName outDir outBase file_name toks) 142 143findTemplate :: String -> Maybe FilePath -> ConfigM Maybe 144 -> IO (FilePath, [Flag]) 145findTemplate usage mb_libdir config 146 = -- If there's no template specified on the commandline, try to locate it 147 case cmTemplate config of 148 Just t -> 149 return (t, []) 150 Nothing -> do 151 -- If there is no Template flag explicitly specified, try 152 -- to find one. We first look near the executable. This only 153 -- works on Win32 or Hugs (getExecDir). If this finds a template 154 -- file then it's certainly the one we want, even if hsc2hs isn't 155 -- installed where we told Cabal it would be installed. 156 -- 157 -- Next we try the location we told Cabal about. 158 -- 159 -- If IN_GHC_TREE is defined (-fin-ghc-tree), we also try to locate 160 -- the template in the `baseDir`, as provided by the `ghc-boot` 161 -- library. Note that this is a hack to work around only partial 162 -- relocatable support in cabal, and is here to allow the hsc2hs 163 -- built and shipped with ghc to be relocatable with the ghc 164 -- binary distribution it ships with. 165 -- 166 -- If neither of the above work, then hopefully we're on Unix and 167 -- there's a wrapper script which specifies an explicit template flag. 168 mb_templ1 <- 169 case mb_libdir of 170 Nothing -> return Nothing 171 Just path -> do 172 -- Euch, this is horrible. Unfortunately 173 -- Paths_hsc2hs isn't too useful for a 174 -- relocatable binary, though. 175 let 176 templ1 = path ++ "/template-hsc.h" 177 incl = path ++ "/include/" 178 exists1 <- doesFileExist templ1 179 if exists1 180 then return $ Just (templ1, CompFlag ("-I" ++ incl)) 181 else return Nothing 182 mb_templ2 <- case mb_templ1 of 183 Just (templ1, incl) -> 184 return $ Just (templ1, [incl]) 185 Nothing -> do 186 templ2 <- getDataFileName "template-hsc.h" 187 exists2 <- doesFileExist templ2 188 if exists2 189 then return $ Just (templ2, []) 190 else return Nothing 191 case mb_templ2 of 192 Just x -> return x 193#if defined(IN_GHC_TREE) 194 Nothing -> do 195 -- XXX: this will *not* work on windows for symlinks, until `getExecutablePath` in `base` is 196 -- fixed. The alternative would be to bring the whole logic from the SysTools module in here 197 -- which is rather excessive. See Trac #14483. 198 let getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath 199 mb_templ3 <- fmap (</> "template-hsc.h") <$> getBaseDir 200 mb_exists3 <- mapM doesFileExist mb_templ3 201 case (mb_templ3, mb_exists3) of 202 (Just templ3, Just True) -> return (templ3, []) 203 _ -> die ("No template specified, and template-hsc.h not located.\n\n" ++ usage) 204#else 205 Nothing -> die ("No template specified, and template-hsc.h not located.\n\n" ++ usage) 206#endif 207 208findCompiler :: Maybe FilePath -> ConfigM Maybe -> IO FilePath 209findCompiler mb_libdir config 210 = case cmCompiler config of 211 Just c -> return c 212 Nothing -> 213 do let search_path = do 214 mb_path <- findExecutable default_compiler 215 case mb_path of 216 Nothing -> 217 die ("Can't find "++default_compiler++"\n") 218 Just path -> return path 219 -- if this hsc2hs is part of a GHC installation on 220 -- Windows, then we should use the mingw gcc that 221 -- comes with GHC (#3929) 222 inplaceGccs = case mb_libdir of 223 Nothing -> [] 224 Just d -> [d ++ "/../mingw/bin/gcc.exe"] 225 search [] = search_path 226 search (x : xs) = do b <- doesFileExist x 227 if b then return x else search xs 228 search inplaceGccs 229 230parseFile :: String -> IO [Token] 231parseFile name 232 = do h <- openBinaryFile name ReadMode 233 -- use binary mode so we pass through UTF-8, see GHC ticket #3837 234 -- But then on Windows we end up turning things like 235 -- #let alignment t = e^M 236 -- into 237 -- #define hsc_alignment(t ) printf ( e^M); 238 -- which gcc doesn't like, so strip out any ^M characters. 239 s <- hGetContents h 240 let s' = filter ('\r' /=) s 241 case runParser parser name s' of 242 Success _ _ _ toks -> return toks 243 Failure (SourcePos name' line col) msg -> 244 die (name'++":"++show line++":"++show col++": "++msg++"\n") 245 246getLibDir :: IO (Maybe String) 247getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe" 248 249-- (getExecDir cmd) returns the directory in which the current 250-- executable, which should be called 'cmd', is running 251-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, 252-- you'll get "/a/b/c" back as the result 253getExecDir :: String -> IO (Maybe String) 254getExecDir cmd = 255 getExecPath >>= maybe (return Nothing) removeCmdSuffix 256 where initN n = reverse . drop n . reverse 257 removeCmdSuffix = return . Just . initN (length cmd) . normalise 258 259getExecPath :: IO (Maybe String) 260#if defined(mingw32_HOST_OS) 261getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. 262 where 263 try_size size = allocaArray (fromIntegral size) $ \buf -> do 264 ret <- c_GetModuleFileName nullPtr buf size 265 case ret of 266 0 -> return Nothing 267 _ | ret < size -> fmap Just $ peekCWString buf 268 | otherwise -> try_size (size * 2) 269 270foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" 271 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 272#else 273getExecPath = return Nothing 274#endif 275