module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,
uuagc
) where
import Distribution.Simple
import Distribution.Simple.PreProcess
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import Distribution.PackageDescription
import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..)
, AGFileOptions
, UUAGCOption(..)
, UUAGCOptions
, defaultUUAGCOptions
, fromUUAGCOtoArgs
, fromUUAGCOstoArgs
, lookupFileOptions
)
import Distribution.Simple.UUAGC.Parser
import System.Process( CreateProcess(..), createProcess, CmdSpec(..)
, StdStream(..), runProcess, waitForProcess
, proc
)
import System.Directory
import System.FilePath(pathSeparator, normalise, joinPath, dropFileName)
import System.Exit (ExitCode(..))
import System.IO( openFile, IOMode(..), hFileSize
, hSetFileSize, hClose, hGetContents
, Handle(..), stderr, hPutStr
)
import Control.Exception (throwIO)
uuagcn = "uuagc"
defUUAGCOptions = "uuagc_options"
uuagcUserHook :: UserHooks
uuagcUserHook = simpleUserHooks { hookedPreProcessors = ("ag", uuagc):knownSuffixHandlers
, preBuild = uuagcPreBuild
}
originalPreBuild = preBuild simpleUserHooks
processContent :: Handle -> IO [String]
processContent h = do s <- hGetContents h
return $ words s
putErrorInfo :: Handle -> IO ()
putErrorInfo h = do s <- hGetContents h
hPutStr stderr s
addSearch :: [String] -> [String] -> [String]
addSearch spl fl = [ normalise (joinPath [sp, f]) | sp <- spl, f <- fl]
throwFailure :: IO ()
throwFailure = do throwIO $ ExitFailure 1
return ()
updateFile :: FilePath -> IO ()
updateFile f = do h <- openFile f AppendMode
i <- hFileSize h
hSetFileSize h (i+1)
hSetFileSize h i
hClose h
updateAGFile :: UUAGCOptions -> FilePath -> [String] -> IO ()
updateAGFile opts f sp = do
let modeOpts = filter isModeOption opts
isModeOption UHaskellSyntax = True
isModeOption ULCKeyWords = True
isModeOption UDoubleColons = True
isModeOption _ = False
args = fromUUAGCOstoArgs modeOpts ++
[ "--genfiledeps"
, "--="++(intercalate ":" sp)
, f
]
(_,(Just ppOutput), (Just ppError),ph) <- createProcess
$ (proc uuagcn args)
{ std_in = Inherit
, std_out = CreatePipe
, std_err = CreatePipe
}
ec <- waitForProcess ph
case ec of
ExitSuccess -> do fls <- processContent ppOutput
let flsC = addSearch sp fls
fmt <- getModificationTime f
flsmt <- mapM getModificationTime flsC
if any (fmt < ) flsmt
then updateFile f
else return ()
(ExitFailure exc) -> do putErrorInfo ppOutput
putErrorInfo ppError
throwFailure
uuagcPreBuild :: Args -> BuildFlags -> IO HookedBuildInfo
uuagcPreBuild args buildF = do
uuagcOpts <- parserAG defUUAGCOptions
let agfls = getAGFileList uuagcOpts
agflSP = map (\(f,opts) -> (f,opts,[dropFileName f])) agfls
mapM_ (\(f,opts,s) -> updateAGFile opts f s) agflSP
originalPreBuild args buildF
getAGFileList :: AGFileOptions -> [(FilePath, UUAGCOptions)]
getAGFileList = map (\(AGFileOption s opts) -> (normalise s, opts))
uuagc :: BuildInfo
-> LocalBuildInfo
-> PreProcessor
uuagc build local =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
do info verbosity (inFile++" has been preprocessed into "++outFile)
print $ "processing: " ++ inFile
opts <- parserAG defUUAGCOptions
let search = dropFileName inFile
options = (fromUUAGCOstoArgs (lookupFileOptions inFile opts))
++ ["-P"++search,"--output="++outFile,inFile]
(_,_,_,ph) <- createProcess (proc uuagcn options)
eCode <- waitForProcess ph
case eCode of
ExitSuccess -> return ()
ExitFailure _ -> throwFailure
}