{-# 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 (MakeStatus -> MakeStatus -> Bool
(MakeStatus -> MakeStatus -> Bool)
-> (MakeStatus -> MakeStatus -> Bool) -> Eq MakeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MakeStatus -> MakeStatus -> Bool
$c/= :: MakeStatus -> MakeStatus -> Bool
== :: MakeStatus -> MakeStatus -> Bool
$c== :: MakeStatus -> MakeStatus -> Bool
Eq,Int -> MakeStatus -> ShowS
[MakeStatus] -> ShowS
MakeStatus -> String
(Int -> MakeStatus -> ShowS)
-> (MakeStatus -> String)
-> ([MakeStatus] -> ShowS)
-> Show MakeStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MakeStatus] -> ShowS
$cshowList :: [MakeStatus] -> ShowS
show :: MakeStatus -> String
$cshow :: MakeStatus -> String
showsPrec :: Int -> MakeStatus -> ShowS
$cshowsPrec :: Int -> MakeStatus -> ShowS
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 (MakeCode -> MakeCode -> Bool
(MakeCode -> MakeCode -> Bool)
-> (MakeCode -> MakeCode -> Bool) -> Eq MakeCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MakeCode -> MakeCode -> Bool
$c/= :: MakeCode -> MakeCode -> Bool
== :: MakeCode -> MakeCode -> Bool
$c== :: MakeCode -> MakeCode -> Bool
Eq,Int -> MakeCode -> ShowS
[MakeCode] -> ShowS
MakeCode -> String
(Int -> MakeCode -> ShowS)
-> (MakeCode -> String) -> ([MakeCode] -> ShowS) -> Show MakeCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MakeCode] -> ShowS
$cshowList :: [MakeCode] -> ShowS
show :: MakeCode -> String
$cshow :: MakeCode -> String
showsPrec :: Int -> MakeCode -> ShowS
$cshowsPrec :: Int -> MakeCode -> ShowS
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 (MergeStatus -> MergeStatus -> Bool
(MergeStatus -> MergeStatus -> Bool)
-> (MergeStatus -> MergeStatus -> Bool) -> Eq MergeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MergeStatus -> MergeStatus -> Bool
$c/= :: MergeStatus -> MergeStatus -> Bool
== :: MergeStatus -> MergeStatus -> Bool
$c== :: MergeStatus -> MergeStatus -> Bool
Eq,Int -> MergeStatus -> ShowS
[MergeStatus] -> ShowS
MergeStatus -> String
(Int -> MergeStatus -> ShowS)
-> (MergeStatus -> String)
-> ([MergeStatus] -> ShowS)
-> Show MergeStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MergeStatus] -> ShowS
$cshowList :: [MergeStatus] -> ShowS
show :: MergeStatus -> String
$cshow :: MergeStatus -> String
showsPrec :: Int -> MergeStatus -> ShowS
$cshowsPrec :: Int -> MergeStatus -> ShowS
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 unnecessary.
--
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 :: String -> [String] -> IO MakeStatus
make String
src [String]
args = String -> [String] -> Bool -> IO MakeStatus
rawMake String
src (String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)  Bool
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 :: String -> [String] -> IO MakeStatus
makeAll String
src [String]
args =
    String -> [String] -> Bool -> IO MakeStatus
rawMake String
src ( String
"--make"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-no-hs-main"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-v0"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args ) Bool
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 :: String -> String -> [String] -> IO MakeStatus
makeWith String
src String
stub [String]
args = do
    MergeStatus
status <- String -> String -> IO MergeStatus
merge String
src String
stub
    case MergeStatus
status of
        MergeFailure [String]
errs -> MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MakeStatus
MakeFailure (String
"merge failed:\n"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
errs)
        MergeSuccess MakeCode
_ [String]
args' String
tmpf -> do
                 MakeStatus
status' <- String -> [String] -> Bool -> IO MakeStatus
rawMake String
tmpf (String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) Bool
True
                 MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return MakeStatus
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 :: Module -> IO Bool
hasChanged = [String] -> Module -> IO Bool
hasChanged' [String
"hs",String
"lhs"]

hasChanged' :: [String] -> Module -> IO Bool
hasChanged' :: [String] -> Module -> IO Bool
hasChanged' [String]
suffices m :: Module
m@(Module {path :: Module -> String
path = String
p})
    = do Bool
modFile <- String -> IO Bool
doesFileExist String
p
         Maybe String
mbFile <- [String] -> String -> IO (Maybe String)
findFile [String]
suffices String
p
         case Maybe String
mbFile of
           Just String
f | Bool
modFile
             -> do UTCTime
srcT <- String -> IO UTCTime
getModificationTime String
f
                   UTCTime
objT <- String -> IO UTCTime
getModificationTime String
p
                   if UTCTime
srcT UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
objT
                      then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                      else do [Module]
deps <- Module -> IO [Module]
getModuleDeps Module
m
                              [Bool]
depsStatus <- (Module -> IO Bool) -> [Module] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String] -> Module -> IO Bool
hasChanged' [String]
suffices) [Module]
deps
                              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
depsStatus)
           Maybe String
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: Module -> [String] -> IO MakeStatus
recompileAll = [String] -> Module -> [String] -> IO MakeStatus
recompileAll' [String
"hs",String
"lhs"]

recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus
recompileAll' :: [String] -> Module -> [String] -> IO MakeStatus
recompileAll' [String]
suffices Module
m [String]
args
    = do Bool
changed <- Module -> IO Bool
hasChanged Module
m
         if Bool
changed
            then do Maybe String
mbSource <- [String] -> String -> IO (Maybe String)
findFile [String]
suffices (Module -> String
path Module
m)
                    case Maybe String
mbSource of
                      Maybe String
Nothing
                          -> String -> IO MakeStatus
forall a. HasCallStack => String -> a
error (String -> IO MakeStatus) -> String -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find source for object file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Module -> String
path Module
m
                      Just String
source
                          -> String -> [String] -> IO MakeStatus
makeAll String
source [String]
args
            else MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
NotReq (Module -> String
path Module
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 :: String -> [String] -> Bool -> IO MakeStatus
rawMake String
src [String]
args Bool
docheck = do
        Bool
src_exists <- String -> IO Bool
doesFileExist String
src
        if Bool -> Bool
not Bool
src_exists
                then MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MakeStatus
MakeFailure [String
"Source file does not exist: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
src]
                else do {
        ; let (String
obj,String
_) = String -> [String] -> (String, String)
outFilePath String
src [String]
args
        ; Bool
src_changed <- if Bool
docheck then String
src String -> String -> IO Bool
`newer` String
obj else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        ; if Bool -> Bool
not Bool
src_changed
          then MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
NotReq String
obj
          else do
#if DEBUG
                putStr "Compiling object ... " >> hFlush stdout
#endif
                ([String]
err, Bool
success) <- String -> String -> [String] -> IO ([String], Bool)
build String
src String
obj [String]
args
#if DEBUG
                putStrLn "done"
#endif
                MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ if Bool
success
                         then MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
ReComp String
obj
                         else [String] -> MakeStatus
MakeFailure [String]
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], Bool)

build :: String -> String -> [String] -> IO ([String], Bool)
build String
src String
obj [String]
extra_opts = do

    let odir :: String
odir = ShowS
dirname String
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 :: [String]
ghc_opts = [ String
"-O0" ]
        output :: [String]
output   = [ String
"-o", String
obj, String
"-odir", String
odir,
                     String
"-hidir", String
odir, String
"-i" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
odir ]

    let flags :: [String]
flags = [String]
ghc_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
output [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
src]

#if DEBUG
    -- env.
    putStr $ show $ ghc : flags
#endif

    ([String]
_out,[String]
err,Bool
success) <- String -> [String] -> IO ([String], [String], Bool)
exec String
ghc [String]
flags       -- this is a fork()

    Bool
obj_exists <- String -> IO Bool
doesFileExist String
obj -- sanity
    ([String], Bool) -> IO ([String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (([String], Bool) -> IO ([String], Bool))
-> ([String], Bool) -> IO ([String], Bool)
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
obj_exists Bool -> Bool -> Bool
&& Bool
success
             then ([String
"Compiled, but didn't create object file `"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
objString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"'!"], Bool
success)
             else ([String]
err, Bool
success)

-- ---------------------------------------------------------------------
-- | 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 :: String -> String -> IO MergeStatus
merge String
src String
stb = do
    Maybe String
m_mod <- String -> String -> IO (Maybe String)
lookupMerged String
src String
stb
    (String
out,Bool
domerge) <- case Maybe String
m_mod of
                Maybe String
Nothing -> do String
out <- IO String
mkUnique
                              String -> String -> String -> IO ()
addMerge String
src String
stb (ShowS
dropSuffix String
out)
                              (String, Bool) -> IO (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
out, Bool
True) -- definitely out of date
                Just String
nm -> (String, Bool) -> IO (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Bool) -> IO (String, Bool))
-> (String, Bool) -> IO (String, Bool)
forall a b. (a -> b) -> a -> b
$ (String
nm String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
hsSuf, Bool
False)
    String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
domerge

-- | 'mergeTo' behaves like 'merge', but we can specify the file in
-- which to place output.
mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeTo :: String -> String -> String -> IO MergeStatus
mergeTo String
src String
stb String
out = String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
False

-- | 'mergeToDir' behaves like 'merge', but lets you specify a target
-- directory.
mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeToDir :: String -> String -> String -> IO MergeStatus
mergeToDir String
src String
stb String
dir = do
    String
out <- String -> IO String
mkUniqueIn String
dir
    String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
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 :: String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
always_merge = do
    Bool
src_exists <- String -> IO Bool
doesFileExist String
src
    Bool
stb_exists <- String -> IO Bool
doesFileExist String
stb
    case () of {()
_
        | Bool -> Bool
not Bool
src_exists  -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$
                [String] -> MergeStatus
MergeFailure [String
"Source file does not exist : "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
src]
        | Bool -> Bool
not Bool
stb_exists -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$
                [String] -> MergeStatus
MergeFailure [String
"Source file does not exist : "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
stb]
        | Bool
otherwise -> do {

    ;Bool
do_merge <- do Bool
src_changed <- String
src String -> String -> IO Bool
`newer` String
out
                    Bool
stb_changed <- String
stb String -> String -> IO Bool
`newer` String
out
                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
src_changed Bool -> Bool -> Bool
|| Bool
stb_changed

    ;if Bool -> Bool
not Bool
do_merge Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
always_merge
     then MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> [String] -> String -> MergeStatus
MergeSuccess MakeCode
NotReq [] String
out
     else do
        String
src_str <- String -> IO String
readFile' String
src
        String
stb_str <- String -> IO String
readFile' String
stb

        let ([String]
a,[String]
a') = String -> ([String], [String])
parsePragmas String
src_str
            ([String]
b,[String]
b') = String -> ([String], [String])
parsePragmas String
stb_str
            opts :: [String]
opts = [String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
a' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b'

        let e_src_syn :: Either String HsModule
e_src_syn = String -> String -> Either String HsModule
parse String
src String
src_str
            e_stb_syn :: Either String HsModule
e_stb_syn = String -> String -> Either String HsModule
parse String
stb String
stb_str

        -- check if there were parser errors
        case (Either String HsModule
e_src_syn,Either String HsModule
e_stb_syn) of
                (Left String
e,  Either String HsModule
_)       -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MergeStatus
MergeFailure [String
e]
                (Either String HsModule
_ , Left String
e)       -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MergeStatus
MergeFailure [String
e]
                (Right HsModule
src_syn, Right HsModule
stb_syn) -> do {

        ;let mrg_syn :: HsModule
mrg_syn = HsModule -> HsModule -> HsModule
mergeModules HsModule
src_syn HsModule
stb_syn
             mrg_syn' :: HsModule
mrg_syn'= HsModule -> String -> HsModule
replaceModName HsModule
mrg_syn (ShowS
mkModid ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
basename String
out)
             mrg_str :: String
mrg_str = HsModule -> String
pretty HsModule
mrg_syn'

        ;Handle
hdl <- String -> IOMode -> IO Handle
openFile String
out IOMode
WriteMode  -- overwrite!
        ;Handle -> String -> IO ()
hPutStr Handle
hdl String
mrg_str ; Handle -> IO ()
hClose Handle
hdl
        ;MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> [String] -> String -> MergeStatus
MergeSuccess MakeCode
ReComp [String]
opts String
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 :: String -> IO ()
makeClean String
f = let f_hi :: String
f_hi = ShowS
dropSuffix  String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
hiSuf
                  f_o :: String
f_o  = ShowS
dropSuffix  String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
objSuf
              in (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
rm_f [String
f_hi, String
f_o]

makeCleaner :: FilePath -> IO ()
makeCleaner :: String -> IO ()
makeCleaner String
f = String -> IO ()
makeClean String
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
rm_f (ShowS
dropSuffix String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
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 :: String -> IO ()
rm_f String
f = (IOError -> Maybe ()) -> (() -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust IOError -> Maybe ()
doesntExist (\()
_->() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> IO ()
removeFile String
f)
    where
        doesntExist :: IOError -> Maybe ()
doesntExist IOError
ioe
                | IOError -> Bool
isDoesNotExistError IOError
ioe = () -> Maybe ()
forall a. a -> Maybe a
Just ()
                | Bool
otherwise               = Maybe ()
forall a. Maybe a
Nothing

readFile' :: String -> IO String
readFile' String
f = do
    Handle
h <- String -> IOMode -> IO Handle
openFile String
f IOMode
ReadMode
    String
s <- Handle -> IO String
hGetContents Handle
h
    String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Handle -> IO ()
hClose Handle
h
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s