module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,
uuagcUserHook',
uuagc,
uuagcLibUserHook,
uuagcFromString
) where
import Distribution.Simple.BuildPaths (autogenModulesDir)
import Debug.Trace
import Distribution.Simple
import Distribution.Simple.PreProcess
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import Distribution.PackageDescription hiding (Flag)
import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..)
, AGFileOptions
, AGOptionsClass(..)
, lookupFileOptions
, fileClasses
)
import Distribution.Simple.UUAGC.Parser
import Options hiding (verbose)
import Distribution.Verbosity
import System.Process( CreateProcess(..), createProcess, CmdSpec(..)
, StdStream(..), runProcess, waitForProcess
, shell)
import System.Directory(getModificationTime
,doesFileExist
,removeFile)
import System.FilePath(pathSeparators,
(</>),
takeFileName,
normalise,
joinPath,
dropFileName,
addExtension,
dropExtension,
splitDirectories)
import System.Exit (ExitCode(..))
import System.IO( openFile, IOMode(..),
hFileSize,
hSetFileSize,
hClose,
hGetContents,
hFlush,
Handle(..), stderr, hPutStr, hPutStrLn)
import System.Exit(exitFailure)
import Control.Exception (throwIO)
import Control.Monad (liftM, when, guard, forM_, forM)
import Control.Arrow ((&&&), second)
import Data.Maybe (maybeToList)
import Data.Either (partitionEithers)
import Data.List (nub)
uuagcn = "uuagc"
defUUAGCOptions :: String
defUUAGCOptions = "uuagc_options"
agClassesFile :: String
agClassesFile = "ag_file_options"
agModule :: String
agModule = "x-agmodule"
agClass :: String
agClass = "x-agclass"
uuagcUserHook :: UserHooks
uuagcUserHook = uuagcUserHook' uuagcn
uuagcUserHook' :: String -> UserHooks
uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath)
uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath])
uuagcFromString uuagcPath args file = do
let argline = uuagcPath ++ concatMap (' ':) (args ++ [file])
(_, Just ppOutput, Just ppError, ph) <- createProcess (shell argline)
{ std_in = Inherit
, std_out = CreatePipe
, std_err = CreatePipe
}
ec <- waitForProcess ph
case ec of
ExitSuccess ->
do fls <- processContent ppOutput
return (ExitSuccess, fls)
(ExitFailure exc) ->
do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc)
putErrorInfo ppOutput
putErrorInfo ppError
return (ExitFailure exc, [])
uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks
uuagcLibUserHook uuagc = hooks where
hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers
, buildHook = uuagcBuildHook uuagc
, sDistHook = uuagcSDistHook uuagc
}
ag = uuagc' uuagc
originalPreBuild = preBuild simpleUserHooks
originalBuildHook = buildHook simpleUserHooks
originalSDistHook = sDistHook simpleUserHooks
processContent :: Handle -> IO [String]
processContent = liftM words . hGetContents
putErrorInfo :: Handle -> IO ()
putErrorInfo h = hGetContents h >>= hPutStr stderr
addSearch :: String -> [String] -> [String]
addSearch sp fl = let sf = [head pathSeparators]
path = if sp == ""
then '.' : sf
else sp ++ sf
in [normalise (joinPath [sp,f]) | f <- fl]
throwFailure :: IO ()
throwFailure = throwIO $ ExitFailure 1
withBuildTmpDir
:: PackageDescription
-> LocalBuildInfo
-> (FilePath -> IO ())
-> IO ()
withBuildTmpDir pkgDescr lbi f = do
#if MIN_VERSION_Cabal(1,8,0)
withLib pkgDescr $ \ _ -> f $ buildDir lbi
#else
withLib pkgDescr () $ \ _ -> f $ buildDir lbi
#endif
withExe pkgDescr $ \ theExe ->
f $ buildDir lbi </> exeName theExe </> exeName theExe ++ "-tmp"
updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
-> FilePath
-> PackageDescription
-> LocalBuildInfo
-> (FilePath, String)
-> IO ()
updateAGFile uuagc classesPath pkgDescr lbi (f, sp) = do
fileOpts <- readFileOptions classesPath
let opts = case lookup f fileOpts of
Nothing -> noOptions
Just x -> x
(ec, fls) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp : (searchPath opts) }) f
case ec of
ExitSuccess ->
do let flsC = addSearch sp fls
when ((not.null) flsC) $ do
flsmt <- mapM getModificationTime flsC
let maxModified = maximum flsmt
removeTmpFile f buildTmp =
do
let files = map (buildTmp </>) . scanr1 (</>) . splitDirectories . (`addExtension` "hs") . dropExtension $ f
forM_ files $ \f -> do
exists <- doesFileExist f
when exists $ do fmt <- getModificationTime f
when (maxModified > fmt) $ removeFile f
withBuildTmpDir pkgDescr lbi $ removeTmpFile f
(ExitFailure exc) ->
do hPutStrLn stderr (show exc)
throwFailure
getAGFileOptions :: [(String, String)] -> IO AGFileOptions
getAGFileOptions extra = do
usesOptionsFile <- doesFileExist defUUAGCOptions
if usesOptionsFile
then do r <- parserAG' defUUAGCOptions
case r of
Left e -> print e >> exitFailure
Right a -> return a
else mapM (parseOptionAG . snd)
$ filter ((== agModule) . fst) extra
getAGClasses :: [(String, String)] -> IO [AGOptionsClass]
getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst)
writeFileOptions :: FilePath -> [(String, Options)] -> IO ()
writeFileOptions classesPath opts = do
hClasses <- openFile classesPath WriteMode
hPutStr hClasses $ show [(s,optionsToString opt) | (s,opt) <- opts]
hFlush hClasses
hClose hClasses
readFileOptions :: FilePath -> IO [(String, Options)]
readFileOptions classesPath = do
hClasses <- openFile classesPath ReadMode
sClasses <- hGetContents hClasses
classes <- readIO sClasses :: IO [(String, [String])]
hClose hClasses
return $ [(s,opt) | (s,str) <- classes, let (opt,_,_) = getOptions str]
getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options)
getOptionsFromClass classes fOpt =
second (foldl combineOptions (opts fOpt))
. partitionEithers $ do
fClass <- fileClasses fOpt
case fClass `lookup` classes of
Just x -> return $ Right x
Nothing -> return $ Left $ "Warning: The class "
++ show fClass
++ " is not defined."
uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
-> PackageDescription
-> Maybe LocalBuildInfo
-> UserHooks
-> SDistFlags
-> IO ()
uuagcSDistHook uuagc pd mbLbi uh df = do
originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df
uuagcBuildHook
:: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
uuagcBuildHook uuagc pd lbi uh bf = do
let classesPath = buildDir lbi </> agClassesFile
commonHook uuagc classesPath pd lbi (buildVerbosity bf)
originalBuildHook pd lbi uh bf
commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
-> FilePath
-> PackageDescription
-> LocalBuildInfo
-> Flag Verbosity
-> IO ()
commonHook uuagc classesPath pd lbi fl = do
let verbosity = fromFlagOrDefault normal fl
when (verbosity >= verbose) $ putStrLn ("commonHook: Assuming AG classesPath: " ++ classesPath)
createDirectoryIfMissingVerbose verbosity True (buildDir lbi)
let lib = library pd
exes = executables pd
bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes
classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd)
options <- getAGFileOptions (bis >>= customFieldsBI)
fileOptions <- forM options (\ opt ->
let (notFound, opts) = getOptionsFromClass classes $ opt
in do when (verbosity >= verbose) $ putStrLn ("options for " ++ filename opt ++ ": " ++ unwords (optionsToString opts))
forM_ notFound (hPutStrLn stderr) >> return (normalise . filename $ opt, opts))
writeFileOptions classesPath fileOptions
let agflSP = map (id &&& dropFileName) $ nub $ getAGFileList options
mapM_ (updateAGFile uuagc classesPath pd lbi) agflSP
getAGFileList :: AGFileOptions -> [FilePath]
getAGFileList = map (normalise . filename)
uuagc :: BuildInfo -> LocalBuildInfo -> PreProcessor
uuagc = uuagc' (uuagcFromString uuagcn)
uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
-> BuildInfo
-> LocalBuildInfo
-> PreProcessor
uuagc' uuagc build lbi =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->
do info verbosity $ concat [inFile, " has been preprocessed into ", outFile]
print $ "processing: " ++ inFile ++ " generating: " ++ outFile
let classesPath = buildDir lbi </> agClassesFile
when (verbosity >= verbose) $ putStrLn ("uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath)
fileOpts <- readFileOptions classesPath
let opts = case lookup inFile fileOpts of
Nothing -> noOptions
Just x -> x
search = dropFileName inFile
options = opts { searchPath = search : (searchPath opts)
, outputFiles = outFile : (outputFiles opts) }
(eCode,_) <- uuagc (optionsToString options) inFile
case eCode of
ExitSuccess -> return ()
ExitFailure _ -> throwFailure
}
nouuagc :: BuildInfo -> LocalBuildInfo -> PreProcessor
nouuagc build lbi =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
info verbosity ("skipping: " ++ outFile)
}