298 lines
10 KiB
Haskell
298 lines
10 KiB
Haskell
|
{-# OPTIONS -cpp #-}
|
||
|
|
--
|
||
|
|
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
||
|
|
--
|
||
|
|
-- This library is free software; you can redistribute it and/or
|
||
|
|
-- modify it under the terms of the GNU Lesser General Public
|
||
|
|
-- License as published by the Free Software Foundation; either
|
||
|
|
-- version 2.1 of the License, or (at your option) any later version.
|
||
|
|
--
|
||
|
|
-- This library is distributed in the hope that it will be useful,
|
||
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
|
|
-- Lesser General Public License for more details.
|
||
|
|
--
|
||
|
|
-- You should have received a copy of the GNU Lesser General Public
|
||
|
|
-- License along with this library; if not, write to the Free Software
|
||
|
|
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
|
||
|
|
-- USA
|
||
|
|
--
|
||
|
|
|
||
|
|
module Plugins.Make (
|
||
|
|
|
||
|
|
make,
|
||
|
|
makeAll,
|
||
|
|
makeWith,
|
||
|
|
MakeStatus(..),
|
||
|
|
MakeCode(..),
|
||
|
|
|
||
|
|
merge,
|
||
|
|
mergeTo,
|
||
|
|
mergeToDir,
|
||
|
|
MergeStatus(..),
|
||
|
|
MergeCode,
|
||
|
|
|
||
|
|
makeClean,
|
||
|
|
makeCleaner,
|
||
|
|
|
||
|
|
build, {- internal -}
|
||
|
|
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Plugins.Utils
|
||
|
|
import Plugins.Parser
|
||
|
|
import Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
|
||
|
|
import Plugins.Env ( lookupMerged, addMerge )
|
||
|
|
|
||
|
|
import System.IO
|
||
|
|
import System.Directory ( doesFileExist, removeFile )
|
||
|
|
|
||
|
|
import Control.Exception ( handleJust )
|
||
|
|
import GHC.IOBase ( Exception(IOException) )
|
||
|
|
|
||
|
|
#if __GLASGOW_HASKELL__ >= 604
|
||
|
|
import System.IO.Error ( isDoesNotExistError )
|
||
|
|
#endif
|
||
|
|
|
||
|
|
------------------------------------------------------------------------
|
||
|
|
--
|
||
|
|
-- A better compiler status.
|
||
|
|
--
|
||
|
|
data MakeStatus
|
||
|
|
= MakeSuccess MakeCode FilePath
|
||
|
|
| MakeFailure Errors
|
||
|
|
deriving (Eq,Show)
|
||
|
|
|
||
|
|
data MakeCode = ReComp | NotReq
|
||
|
|
deriving (Eq,Show)
|
||
|
|
|
||
|
|
------------------------------------------------------------------------
|
||
|
|
--
|
||
|
|
-- An equivalent status for the preprocessor (merge)
|
||
|
|
--
|
||
|
|
data MergeStatus
|
||
|
|
= MergeSuccess MergeCode Args FilePath
|
||
|
|
| MergeFailure Errors
|
||
|
|
deriving (Eq,Show)
|
||
|
|
|
||
|
|
type MergeCode = MakeCode
|
||
|
|
|
||
|
|
type Args = [Arg]
|
||
|
|
type Errors = [String]
|
||
|
|
|
||
|
|
-- ---------------------------------------------------------------------
|
||
|
|
-- | Standard make. Compile a single module, unconditionally.
|
||
|
|
-- Behaves like ghc -c
|
||
|
|
--
|
||
|
|
make :: FilePath -> [Arg] -> IO MakeStatus
|
||
|
|
make src args = rawMake src ("-c":args) True
|
||
|
|
|
||
|
|
-- | Recursive make. Compile a module, and its dependencies if we can
|
||
|
|
-- find them. Takes the top-level file as the first argument.
|
||
|
|
-- Behaves like ghc --make
|
||
|
|
--
|
||
|
|
makeAll :: FilePath -> [Arg] -> IO MakeStatus
|
||
|
|
makeAll src args =
|
||
|
|
rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False
|
||
|
|
|
||
|
|
-- | merge two files; then make them. will leave a .o and .hi file in tmpDir.
|
||
|
|
--
|
||
|
|
makeWith :: FilePath -- ^ a src file
|
||
|
|
-> FilePath -- ^ a syntax stub file
|
||
|
|
-> [Arg] -- ^ any required args
|
||
|
|
-> IO MakeStatus -- ^ path to an object file
|
||
|
|
|
||
|
|
makeWith src stub args = do
|
||
|
|
status <- merge src stub
|
||
|
|
case status of
|
||
|
|
MergeFailure errs -> return $ MakeFailure ("merge failed:\n":errs)
|
||
|
|
MergeSuccess _ args' tmpf -> do
|
||
|
|
status' <- rawMake tmpf ("-c": args' ++ args) True
|
||
|
|
return status'
|
||
|
|
|
||
|
|
-- ---------------------------------------------------------------------
|
||
|
|
-- rawMake : really do the compilation
|
||
|
|
-- Conditional on file modification times, compile a .hs file
|
||
|
|
-- When using 'make', the name of the src file must be the name of the
|
||
|
|
-- .o file you are expecting back
|
||
|
|
--
|
||
|
|
-- Problem: we use GHC producing stdout to indicate compilation failure.
|
||
|
|
-- We should instead check the error conditions. I.e. --make will
|
||
|
|
-- produce output, but of course compiles correctly. TODO
|
||
|
|
-- So, e.g. --make requires -v0 to stop spurious output confusing
|
||
|
|
-- rawMake
|
||
|
|
--
|
||
|
|
-- Problem :: makeAll incorrectly refuses to recompile if the top level
|
||
|
|
-- src isn't new.
|
||
|
|
--
|
||
|
|
|
||
|
|
rawMake :: FilePath -- ^ src
|
||
|
|
-> [Arg] -- ^ any compiler args
|
||
|
|
-> Bool -- ^ do our own recompilation checking
|
||
|
|
-> IO MakeStatus
|
||
|
|
|
||
|
|
rawMake src args docheck = do
|
||
|
|
src_exists <- doesFileExist src
|
||
|
|
if not src_exists
|
||
|
|
then return $ MakeFailure ["Source file does not exist: "++src]
|
||
|
|
else do {
|
||
|
|
; let (obj,_) = outFilePath src args
|
||
|
|
; src_changed <- if docheck then src `newer` obj else return True
|
||
|
|
; if not src_changed
|
||
|
|
then return $ MakeSuccess NotReq obj
|
||
|
|
else do
|
||
|
|
#if DEBUG
|
||
|
|
putStr "Compiling object ... " >> hFlush stdout
|
||
|
|
#endif
|
||
|
|
err <- build src obj args
|
||
|
|
#if DEBUG
|
||
|
|
putStrLn "done"
|
||
|
|
#endif
|
||
|
|
return $ if null err
|
||
|
|
then MakeSuccess ReComp obj
|
||
|
|
else MakeFailure err
|
||
|
|
}
|
||
|
|
|
||
|
|
--
|
||
|
|
-- compile a .hs file to a .o file
|
||
|
|
--
|
||
|
|
-- If the plugin needs to import an api (which should be almost
|
||
|
|
-- everyone) then the ghc flags to find the api need to be provided as
|
||
|
|
-- arguments
|
||
|
|
--
|
||
|
|
build :: FilePath -- path to .hs source
|
||
|
|
-> FilePath -- path to object file
|
||
|
|
-> [String] -- any extra cmd line flags
|
||
|
|
-> IO [String]
|
||
|
|
|
||
|
|
build src obj extra_opts = do
|
||
|
|
|
||
|
|
let odir = dirname obj -- *always* put the .hi file next to the .o file
|
||
|
|
|
||
|
|
let ghc_opts = [ "-Onot" ]
|
||
|
|
output = [ "-o", obj, "-odir", odir,
|
||
|
|
"-hidir", odir, "-i" ++ odir ]
|
||
|
|
|
||
|
|
let flags = ghc_opts ++ output ++ extra_opts ++ [src]
|
||
|
|
|
||
|
|
#if DEBUG
|
||
|
|
-- env.
|
||
|
|
putStr $ show $ ghc : flags
|
||
|
|
#endif
|
||
|
|
(_,err) <- exec ghc flags -- this is a fork()
|
||
|
|
|
||
|
|
obj_exists <- doesFileExist obj -- sanity
|
||
|
|
return $ if not obj_exists && null err -- no errors, but no object?
|
||
|
|
then ["Compiled, but didn't create object file `"++obj++"'!"]
|
||
|
|
else err
|
||
|
|
|
||
|
|
-- ---------------------------------------------------------------------
|
||
|
|
-- | Merge to source files into a temporary file. If we've tried to
|
||
|
|
-- merge these two stub files before, then reuse the module name (helps
|
||
|
|
-- recompilation checking)
|
||
|
|
--
|
||
|
|
merge :: FilePath -> FilePath -> IO MergeStatus
|
||
|
|
merge src stb = do
|
||
|
|
m_mod <- lookupMerged src stb
|
||
|
|
(out,domerge) <- case m_mod of
|
||
|
|
Nothing -> do out <- mkUnique
|
||
|
|
addMerge src stb (dropSuffix out)
|
||
|
|
return (out, True) -- definitely out of date
|
||
|
|
Just nm -> return $ (nm <> hsSuf, False)
|
||
|
|
rawMerge src stb out domerge
|
||
|
|
|
||
|
|
-- | Merge to source files and store them in the specified output file,
|
||
|
|
-- instead of a temp file as merge does.
|
||
|
|
--
|
||
|
|
mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus
|
||
|
|
mergeTo src stb out = rawMerge src stb out False
|
||
|
|
|
||
|
|
mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus
|
||
|
|
mergeToDir src stb dir = do
|
||
|
|
out <- mkUniqueIn dir
|
||
|
|
rawMerge src stb out True
|
||
|
|
|
||
|
|
-- ---------------------------------------------------------------------
|
||
|
|
-- Conditional on file modification times, merge a src file with a
|
||
|
|
-- syntax stub file into a result file.
|
||
|
|
--
|
||
|
|
-- Merge should only occur if the srcs has changed since last time.
|
||
|
|
-- Parser errors result in MergeFailure, and are reported to the client
|
||
|
|
--
|
||
|
|
-- Also returns a list of cmdline flags found in pragmas in the src of
|
||
|
|
-- the files. This last feature exists as OPTION pragmas aren't handled
|
||
|
|
-- (for obvious reasons, relating to the implementation of OPTIONS
|
||
|
|
-- parsing in GHC) by the library parser, and, also, we want a way for
|
||
|
|
-- the user to introduce *dynamic* cmd line flags in the .conf file.
|
||
|
|
-- This is achieved via the GLOBALOPTIONS pragma : an extension to ghc
|
||
|
|
-- pragma syntax
|
||
|
|
--
|
||
|
|
rawMerge :: FilePath -> FilePath -> FilePath -> Bool -> IO MergeStatus
|
||
|
|
rawMerge src stb out always_merge = do
|
||
|
|
src_exists <- doesFileExist src
|
||
|
|
stb_exists <- doesFileExist stb
|
||
|
|
case () of {_
|
||
|
|
| not src_exists -> return $
|
||
|
|
MergeFailure ["Source file does not exist : "++src]
|
||
|
|
| not stb_exists -> return $
|
||
|
|
MergeFailure ["Source file does not exist : "++stb]
|
||
|
|
| otherwise -> do {
|
||
|
|
|
||
|
|
;do_merge <- do src_changed <- src `newer` out
|
||
|
|
stb_changed <- stb `newer` out
|
||
|
|
return $ src_changed || stb_changed
|
||
|
|
|
||
|
|
;if not do_merge && not always_merge
|
||
|
|
then return $ MergeSuccess NotReq [] out
|
||
|
|
else do
|
||
|
|
src_str <- readFile src
|
||
|
|
stb_str <- readFile stb
|
||
|
|
|
||
|
|
let (a,a') = parsePragmas src_str
|
||
|
|
(b,b') = parsePragmas stb_str
|
||
|
|
opts = a ++ a' ++ b ++ b'
|
||
|
|
|
||
|
|
let e_src_syn = parse src src_str
|
||
|
|
e_stb_syn = parse stb stb_str
|
||
|
|
|
||
|
|
-- check if there were parser errors
|
||
|
|
case (e_src_syn,e_stb_syn) of
|
||
|
|
(Left e, _) -> return $ MergeFailure [e]
|
||
|
|
(_ , Left e) -> return $ MergeFailure [e]
|
||
|
|
(Right src_syn, Right stb_syn) -> do {
|
||
|
|
|
||
|
|
;let mrg_syn = mergeModules src_syn stb_syn
|
||
|
|
mrg_syn'= replaceModName mrg_syn (mkModid $ basename out)
|
||
|
|
mrg_str = pretty mrg_syn'
|
||
|
|
|
||
|
|
;hdl <- openFile out WriteMode -- overwrite!
|
||
|
|
;hPutStr hdl mrg_str ; hClose hdl
|
||
|
|
;return $ MergeSuccess ReComp opts out -- must have recreated file
|
||
|
|
}}}
|
||
|
|
|
||
|
|
-- ---------------------------------------------------------------------
|
||
|
|
-- | makeClean : assuming we some element of [f.hs,f.hi,f.o], remove the
|
||
|
|
-- .hi and .o components. Silently ignore any missing components. *Does
|
||
|
|
-- not remove .hs files*. To do that use makeCleaner. This would be
|
||
|
|
-- useful for merged files, for example.
|
||
|
|
--
|
||
|
|
makeClean :: FilePath -> IO ()
|
||
|
|
makeClean f = let f_hi = dropSuffix f <> hiSuf
|
||
|
|
f_o = dropSuffix f <> objSuf
|
||
|
|
in mapM_ rm_f [f_hi, f_o]
|
||
|
|
|
||
|
|
makeCleaner :: FilePath -> IO ()
|
||
|
|
makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf)
|
||
|
|
|
||
|
|
-- internal:
|
||
|
|
-- try to remove a file, ignoring if it didn't exist in the first place
|
||
|
|
-- Doesn't seem to be able to remove all files in all circumstances, why?
|
||
|
|
--
|
||
|
|
rm_f f = handleJust doesntExist (\_->return ()) (removeFile f)
|
||
|
|
where
|
||
|
|
doesntExist (IOException ioe)
|
||
|
|
| isDoesNotExistError ioe = Just ()
|
||
|
|
| otherwise = Nothing
|
||
|
|
doesntExist _ = Nothing
|
||
|
|
|