module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,
uuagc
) 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(..)
, UUAGCOption(..)
, UUAGCOptions
, defaultUUAGCOptions
, fromUUAGCOtoArgs
, fromUUAGCOstoArgs
, lookupFileOptions
, fileClasses
)
import Distribution.Simple.UUAGC.Parser
import Distribution.Verbosity
import System.Process( CreateProcess(..), createProcess, CmdSpec(..)
, StdStream(..), runProcess, waitForProcess
, proc)
import System.Directory(getModificationTime
,doesFileExist
,removeFile)
import System.FilePath(pathSeparators,
(</>),
takeFileName,
normalise,
joinPath,
dropFileName,
addExtension,
dropExtension)
import System.Exit (ExitCode(..))
import System.IO( openFile, IOMode(..),
hFileSize,
hSetFileSize,
hClose,
hGetContents,
hFlush,
Handle(..), stderr, hPutStr, hPutStrLn)
import System(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 = "uuagc_options"
agClassesFile = ".ag_file_options"
agModule = "x-agmodule"
agClass = "x-agclass"
uuagcUserHook :: UserHooks
uuagcUserHook = simpleUserHooks {hookedPreProcessors = ("ag", uuagc):("lag",uuagc):knownSuffixHandlers
,buildHook = uuagcBuildHook
,postBuild = uuagcPostBuild
}
originalPreBuild = preBuild simpleUserHooks
originalBuildHook = buildHook 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"
tmpFile :: FilePath -> FilePath -> FilePath
tmpFile buildTmp = (buildTmp </>)
. (`addExtension` "hs")
. dropExtension
. takeFileName
updateAGFile :: PackageDescription
-> LocalBuildInfo
-> (FilePath, String)
-> IO ()
updateAGFile pkgDescr lbi (f, sp) = do
fileOpts <- readFileOptions
let opts = case lookup f fileOpts of
Nothing -> []
Just x -> x
modeOpts = filter isModeOption opts
isModeOption UHaskellSyntax = True
isModeOption ULCKeyWords = True
isModeOption UDoubleColons = True
isModeOption _ = False
(_, Just ppOutput, Just ppError, ph) <- newProcess modeOpts
ec <- waitForProcess ph
case ec of
ExitSuccess ->
do fls <- processContent ppOutput
let flsC = addSearch sp fls
when ((not.null) flsC) $ do
flsmt <- mapM getModificationTime flsC
let maxModified = maximum flsmt
removeTmpFile f = do
exists <- doesFileExist f
when exists $ do
fmt <- getModificationTime f
when (maxModified > fmt) $ removeFile f
withBuildTmpDir pkgDescr lbi $ removeTmpFile . (`tmpFile` f)
(ExitFailure exc) ->
do putErrorInfo ppOutput
putErrorInfo ppError
throwFailure
where newProcess mopts = createProcess $ (proc uuagcn (fromUUAGCOstoArgs mopts ++ ["--genfiledeps"
,"--=" ++ intercalate ":" [sp]
,f
]
)
)
{ std_in = Inherit
, std_out = CreatePipe
, std_err = CreatePipe
}
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 :: [(String, [UUAGCOption])] -> IO ()
writeFileOptions opts = do
hClasses <- openFile agClassesFile WriteMode
hPutStr hClasses $ show opts
hFlush hClasses
hClose hClasses
readFileOptions :: IO [(String, [UUAGCOption])]
readFileOptions = do
hClasses <- openFile agClassesFile ReadMode
sClasses <- hGetContents hClasses
classes <- readIO sClasses :: IO [(String, [UUAGCOption])]
hClose hClasses
return $ classes
getOptionsFromClass :: [(String, [UUAGCOption])] -> AGFileOption -> ([String], [UUAGCOption])
getOptionsFromClass classes fOpt =
second (nub . concat . ((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."
uuagcBuildHook
:: PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
uuagcBuildHook pd lbi uh bf = do
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 case buildVerbosity bf of
Flag v | v >= verbose -> putStrLn ("options for " ++ filename opt ++ ": " ++ show opts)
_ -> return ()
forM_ notFound (hPutStrLn stderr) >> return (normalise . filename $ opt, opts))
writeFileOptions fileOptions
let agflSP = map (id &&& dropFileName) $ nub $ getAGFileList options
mapM_ (updateAGFile pd lbi) agflSP
originalBuildHook pd lbi uh bf
uuagcPostBuild _ _ _ _ = do
exists <- doesFileExist agClassesFile
when exists $ removeFile agClassesFile
getAGFileList :: AGFileOptions -> [FilePath]
getAGFileList = map (normalise . filename)
uuagc :: BuildInfo
-> LocalBuildInfo
-> PreProcessor
uuagc build local =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->
do info verbosity $ concat [inFile, " has been preprocessed into ", outFile]
print $ "processing: " ++ inFile ++ " generating: " ++ outFile
fileOpts <- readFileOptions
let opts = case lookup inFile fileOpts of
Nothing -> []
Just x -> x
search = dropFileName inFile
options = fromUUAGCOstoArgs opts
++ ["-P" ++ search, "--output=" ++ outFile, inFile]
(_,_,_,ph) <- createProcess (proc uuagcn options)
eCode <- waitForProcess ph
case eCode of
ExitSuccess -> return ()
ExitFailure _ -> throwFailure
}