{-# LANGUAGE CPP #-} -- -- Copyright (C) 2004..2010 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 -- -- | An interface to a Haskell compiler, providing the facilities of a -- compilation manager. module System.Plugins.Make ( -- * The @MakeStatus@ type MakeStatus(..), -- * The @MakeCode@ type MakeCode(..), -- * Compiling Haskell modules make, makeAll, makeWith, -- * Handling reecompilation hasChanged, hasChanged', recompileAll, recompileAll', -- * Merging together Haskell source files MergeStatus(..), MergeCode, Args, Errors, merge, mergeTo, mergeToDir, -- * Cleaning up temporary files makeClean, makeCleaner, -- * Low-level compilation primitives 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, hGetContents) #else import System.IO (openFile, IOMode(..),hClose,hPutStr, hGetContents) #endif import System.Directory ( doesFileExist, removeFile , getModificationTime ) import Control.Exception ( handleJust ) #if __GLASGOW_HASKELL__ >= 604 import System.IO.Error ( isDoesNotExistError ) #endif -- -- | The @MakeStatus@ type represents success or failure of compilation. -- Compilation can fail for the usual reasons: syntax errors, type -- errors and the like. The @MakeFailure@ constructor returns any error -- messages produced by the compiler. @MakeSuccess@ returns a @MakeCode@ -- value, and the path to the object file produced. -- data MakeStatus = MakeSuccess MakeCode FilePath -- ^ compilation was successful | MakeFailure Errors -- ^ compilation failed deriving (Eq,Show) -- | The @MakeCode@ type is used when compilation is successful, to -- distinguish two cases: -- * The source file needed recompiling, and this was done -- * The source file was already up to date, recompilation was skipped data MakeCode = ReComp -- ^ recompilation was performed | NotReq -- ^ recompilation was not required deriving (Eq,Show) -- -- | An equivalent status for the preprocessor phase -- data MergeStatus = MergeSuccess MergeCode Args FilePath -- ^ the merge was successful | MergeFailure Errors -- ^ failure, and any errors returned deriving (Eq,Show) -- -- | Merging may be avoided if the source files are older than an -- existing merged result. The @MergeCode@ type indicates whether -- merging was performed, or whether it was unneccessary. -- type MergeCode = MakeCode -- | A list of @String@ arguments type Args = [Arg] -- | Convience synonym type Errors = [String] -- touch. -- --------------------------------------------------------------------- -- | One-shot unconditional compilation of a single Haskell module. -- @make@ behaves like 'ghc -c'. Extra arguments to 'ghc' may be passed -- in the 'args' parameter, they will be appended to the argument list. -- @make@ always recompiles its target, whether or not it is out of -- date. -- -- A side-effect of calling 'make' is to have GHC produce a @.hi@ file -- containing a list of package and objects that the source depends on. -- Subsequent calls to 'load' will use this interface file to load -- module and library dependencies prior to loading the object itself. -- make :: FilePath -> [Arg] -> IO MakeStatus make src args = rawMake src ("-c":args) True -- | 'makeAll' recursively compiles any dependencies it can find using -- GHC's @--make@ flag. Dependencies will be recompiled only if they are -- visible to 'ghc' -- this may require passing appropriate include path -- flags in the 'args' parameter. 'makeAll' takes the top-level file as -- the first argument. -- makeAll :: FilePath -> [Arg] -> IO MakeStatus makeAll src args = rawMake src ( "--make":"-no-hs-main":"-c":"-v0":args ) False -- | This is a variety of 'make' that first calls 'merge' to -- combine the plugin source with a syntax stub. The result is then -- compiled. This is provided for EDSL authors who wish to add extra -- syntax to a user\'s source. It is important to note that the -- module and types from the second file argument are used to override -- any of those that appear in the first argument. For example, consider -- the following source files: -- -- > module A where -- > a :: Integer -- > a = 1 -- -- and -- -- > module B where -- > a :: Int -- -- Calling @makeWith "A" "B" []@ will merge the module name and types -- from module B into module A, generating a third file: -- -- > {-# LINE 1 "A.hs" #-} -- > module MxYz123 where -- > {-# LINE 3 "B.hs" #-} -- > a :: Int -- > {-# LINE 4 "A.hs" #-} -- > a = 1 -- 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' ------------------------------------------------------------------------ -- -- | @hasChanged@ 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 -- -- | 'recompileAll' is like 'makeAll', but rather than relying on -- @ghc --make@, we explicitly check a module\'s dependencies using our -- internal map of module dependencies. Performance is thus better, and -- the result is more accurate. -- 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)) -- --------------------------------------------------------------------- -- 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 } -- -- | Lower-level than 'make'. 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 -- does this work in the presence of hier plugins? -- won't handle hier names properly. let ghc_opts = [ "-O0" ] 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) -- -- The merging operation is extremely useful for providing extra default -- syntax. An EDSL user then need not worry about declaring module -- names, or having required imports. In this way, the stub file can -- also be used to provide syntax declarations that would be -- inconvenient to require of the plugin author. -- -- 'merge' will include any import and export declarations written in -- the stub, as well as any module name, so that plugin author\'s need -- not worry about this compulsory syntax. Additionally, if a plugin -- requires some non-standard library, which must be provided as a -- @-package@ flag to GHC, they may specify this using the non-standard -- @GLOBALOPTIONS@ pragma. Options specified in the source this way -- will be added to the command line. This is useful for users who wish -- to use GHC flags that cannot be specified using the conventional -- @OPTIONS@ pragma. The merging operation uses the parser hs-plugins -- was configured with, either 'Language.Haskell' or the HSX parser, to -- parse Haskell source files. -- 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 -- | 'mergeTo' behaves like 'merge', but we can specify the file in -- which to place output. mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus mergeTo src stb out = rawMerge src stb out False -- | 'mergeToDir' behaves like 'merge', but lets you specify a target -- directory. 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 ioe | isDoesNotExistError ioe = Just () | otherwise = Nothing readFile' f = do h <- openFile f ReadMode s <- hGetContents h length s `seq` return () hClose h return s