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