356 lines
12 KiB
Haskell
356 lines
12 KiB
Haskell
--
|
|
-- Copyright (C) 2004-5 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 System.Plugins.Make (
|
|
|
|
make,
|
|
makeAll,
|
|
makeWith,
|
|
MakeStatus(..),
|
|
MakeCode(..),
|
|
|
|
hasChanged,
|
|
hasChanged',
|
|
recompileAll,
|
|
recompileAll',
|
|
|
|
merge,
|
|
mergeTo,
|
|
mergeToDir,
|
|
MergeStatus(..),
|
|
MergeCode,
|
|
|
|
makeClean,
|
|
makeCleaner,
|
|
|
|
build, {- internal -}
|
|
|
|
) where
|
|
|
|
import System.Plugins.Utils
|
|
import System.Plugins.Parser
|
|
import System.Plugins.LoadTypes ( Module (Module, path) )
|
|
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
|
|
import System.Plugins.Process ( exec )
|
|
import System.Plugins.Env ( lookupMerged, addMerge
|
|
, getModuleDeps)
|
|
|
|
#if DEBUG
|
|
import System.IO (hFlush, stdout, openFile, IOMode(..),hClose, hPutStr)
|
|
#else
|
|
import System.IO (openFile, IOMode(..),hClose,hPutStr)
|
|
#endif
|
|
|
|
import System.Directory ( doesFileExist, removeFile
|
|
, getModificationTime )
|
|
|
|
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]
|
|
|
|
--
|
|
-- |Returns @True@ if the module or any of its dependencies have older object files than source files.
|
|
-- Defaults to @True@ if some files couldn't be located.
|
|
--
|
|
hasChanged :: Module -> IO Bool
|
|
hasChanged = hasChanged' ["hs","lhs"]
|
|
|
|
hasChanged' :: [String] -> Module -> IO Bool
|
|
hasChanged' suffices m@(Module {path = p})
|
|
= do modFile <- doesFileExist p
|
|
mbFile <- findFile suffices p
|
|
case mbFile of
|
|
Just f | modFile
|
|
-> do srcT <- getModificationTime f
|
|
objT <- getModificationTime p
|
|
if srcT > objT
|
|
then return True
|
|
else do deps <- getModuleDeps m
|
|
depsStatus <- mapM (hasChanged' suffices) deps
|
|
return (or depsStatus)
|
|
_ -> return True
|
|
|
|
--
|
|
-- |Same as 'makeAll' but with better recompilation checks since module dependencies are known.
|
|
--
|
|
recompileAll :: Module -> [Arg] -> IO MakeStatus
|
|
recompileAll = recompileAll' ["hs","lhs"]
|
|
|
|
recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus
|
|
recompileAll' suffices m args
|
|
= do changed <- hasChanged m
|
|
if changed
|
|
then do mbSource <- findFile suffices (path m)
|
|
case mbSource of
|
|
Nothing
|
|
-> error $ "Couldn't find source for object file: " ++ path m
|
|
Just source
|
|
-> makeAll source args
|
|
else return (MakeSuccess NotReq (path m))
|
|
|
|
-- touch.
|
|
|
|
-- ---------------------------------------------------------------------
|
|
-- | 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
|
|
|
|
(_out,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
|
|
|