{-# LANGUAGE CPP #-}
module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,
                                       uuagcUserHook',
                                       uuagc,
                                       uuagcLibUserHook,
                                       uuagcFromString
                                      ) where

-- import Distribution.Simple.BuildPaths (autogenComponentModulesDir)
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( readProcessWithExitCode )
import System.Directory(getModificationTime
                       ,doesFileExist
                       ,removeFile)
import System.FilePath(pathSeparators,
                       (</>),
                       takeFileName,
                       normalise,
                       joinPath,
                       dropFileName,
                       addExtension,
                       dropExtension,
                       replaceExtension,
                       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,intersperse)
import Data.Map (Map)
import qualified Data.Map as Map

{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-}

-- | 'uuagc' returns the name of the uuagc compiler
uuagcn = "uuagc"

-- | 'defUUAGCOptions' returns the default names of the uuagc options
defUUAGCOptions :: String
defUUAGCOptions = "uuagc_options"

-- | File used to store de classes defined in the cabal file.
agClassesFile :: String
agClassesFile = "ag_file_options"

-- | The prefix used for the cabal file optionsw
agModule :: String
agModule = "x-agmodule"

-- | The prefix used for the cabal file options used for defining classes
agClass :: String
agClass  = "x-agclass"

-- | Deprecated userhook
uuagcUserHook :: UserHooks
uuagcUserHook = uuagcUserHook' uuagcn

-- | Deprecated userhook
uuagcUserHook' :: String -> UserHooks
uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath)

-- | Create uuagc function using shell (old method)
uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath])
uuagcFromString uuagcPath args file = do
  (ec,out,err) <- readProcessWithExitCode uuagcPath (args ++ [file]) ""
  case ec of
    ExitSuccess ->
      do hPutStr stderr err
         return (ExitSuccess, words out)
    (ExitFailure exc) ->
      do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc)
         hPutStr stderr out
         hPutStr stderr err
         return (ExitFailure exc, [])

-- | Main hook, argument should be uuagc function
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

putErrorInfo :: Handle -> IO ()
putErrorInfo h = hGetContents h >>= hPutStr stderr

-- | 'updateAGFile' search into the uuagc options file for a list of all
-- AG Files and theirs file dependencies in order to see if the latters
-- are more updated that the formers, and if this is the case to
-- update the AG File
updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
             -> Map FilePath (Options, Maybe (FilePath, [String]))
             -> (FilePath, (Options, Maybe (FilePath, [String])))
             -> IO ()
updateAGFile _ _ (_,(_,Nothing)) = return ()
updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do
  hasGen <- doesFileExist gen
  when hasGen $ do
    (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file
    case ec of
      ExitSuccess -> do
        let newOpts :: Options 
            newOpts = maybe noOptions fst $ Map.lookup file newOptions
            optRebuild = optionsToString newOpts /= optionsToString opts
        modRebuild <-
          if null files
          then return False
          else do
            flsmt <- mapM getModificationTime files
            let maxModified = maximum flsmt
            fmt <- getModificationTime gen
            return $ maxModified > fmt
        -- When some dependency is newer or options have changed, we should regenerate
        when (optRebuild || modRebuild) $ removeFile gen
      ex@(ExitFailure _) -> throwIO ex

getAGFileOptions :: [(String, String)] -> IO AGFileOptions
getAGFileOptions extra = do
  cabalOpts <- mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra
  usesOptionsFile <- doesFileExist defUUAGCOptions
  if usesOptionsFile
       then do r <- parserAG' defUUAGCOptions
               case r of
                 Left e -> dieNoVerbosity (show e)
                 Right a -> return $ cabalOpts ++ a
       else return cabalOpts

getAGClasses :: [(String, String)] -> IO [AGOptionsClass]
getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst)

writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO ()
writeFileOptions classesPath opts  = do
  hClasses <- openFile classesPath WriteMode
  hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts
  hFlush  hClasses
  hClose  hClasses

readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String])))
readFileOptions classesPath = do
  isFile <- doesFileExist classesPath
  if isFile
    then do hClasses <- openFile classesPath ReadMode
            sClasses <- hGetContents hClasses
            classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String])))
            hClose hClasses
            return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes
    else    return Map.empty

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
--   {-
--   case mbLbi of
--     Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail."
--     Just lbi -> let classesPath = buildDir lbi </> agClassesFile
--                 in commonHook uuagc classesPath pd lbi (sDistVerbosity df)
--   originalSDistHook pd mbLbi uh df
--   -}
--   originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df  -- bypass preprocessors

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
  info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath
  createDirectoryIfMissingVerbose verbosity True (buildDir lbi)
  -- Read already existing options
  -- Map FilePath (Options, Maybe (FilePath,[String]))
  oldOptions <- readFileOptions classesPath
  -- Read options from cabal and settings file
  let lib    = library pd
      exes   = executables pd
      bis    = map libBuildInfo (maybeToList lib) ++ map buildInfo exes
  classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd)
  configOptions <- getAGFileOptions (bis >>= customFieldsBI)
  -- Construct new options map
  newOptionsL <- forM configOptions (\ opt ->
      let (notFound, opts) = getOptionsFromClass classes $ opt
          file = normalise $ filename opt
          gen = maybe Nothing snd $ Map.lookup file oldOptions
      in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts)
            forM_ notFound (hPutStrLn stderr)
            return (file, (opts, gen)))
  let newOptions = Map.fromList newOptionsL
  writeFileOptions classesPath newOptions
  -- Check if files should be regenerated
  mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions

getAGFileList :: AGFileOptions -> [FilePath]
getAGFileList = map (normalise . filename)

uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
uuagc = uuagc' (uuagcFromString uuagcn)

uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
        -> BuildInfo
        -> LocalBuildInfo
        -> ComponentLocalBuildInfo
        -> PreProcessor
uuagc' uuagc build lbi _ =
   PreProcessor {
     platformIndependent = True,
     runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->
                       do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile
                          let classesPath = buildDir lbi </> agClassesFile
                          info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath
                          fileOpts <- readFileOptions classesPath
                          opts <- case Map.lookup inFile fileOpts of
                                       Nothing        -> do warn verbosity $ "No options found for " ++ inFile
                                                            return noOptions
                                       Just (opt,gen) -> return opt
                          let search  = dropFileName inFile
                              options = opts { searchPath = search : hsSourceDirs build ++ searchPath opts
                                             , outputFiles = outFile : (outputFiles opts) }
                          (eCode,_) <- uuagc (optionsToString options) inFile
                          case eCode of
                            ExitSuccess   -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts)
                            ex@(ExitFailure _) -> throwIO ex
                }

nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
nouuagc build lbi _ =
  PreProcessor {
    platformIndependent = True,
    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
      info verbosity ("skipping: " ++ outFile)
  }