{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

module CompilationUtility where

import System.IO
import System.Exit
import System.Process
import Control.Concurrent
import Control.Monad.Trans

import Printer
import Utility


class UtilitySettings c where
  executable :: c -> FilePath
  toStringList :: c -> [String]
  utitle :: c -> Maybe String
  verbose :: c -> Bool



data UtilityResult c = UtilityResult {
  ur_compilation_args :: c,
  ur_stdout :: Handle,
  ur_stderr :: Handle,
  ur_exit_code :: Int,
  ur_output :: String
}


class UtilitySettings c => CompilationUtility c a | c -> a where
  defaultValue :: c -> a


  shellArgs :: c -> CreateProcess
  shellArgs c = (proc (executable c) (toStringList c)) 
                                    {std_out = CreatePipe, std_err = CreatePipe}

  analyseProgress :: c -> Handle -> ProcessHandle -> EitherT String IO ()
  analyseProgress _ _ = catchIO . showProgress
   where
    showProgress :: ProcessHandle -> IO ()
    showProgress phandle = do
      threadDelay $ 1000 * 1000
      m <- getProcessExitCode phandle
      case m of
        Nothing -> putStr "." >> hFlush stdout >> showProgress phandle
        Just _ -> return ()


  success :: UtilityResult c -> EitherT String IO a
  success = return . defaultValue . ur_compilation_args


  failure :: UtilityResult c -> EitherT String IO a
  failure r = do
    errors <- catchIO $ hGetContents $ ur_stderr r
    output <- catchIO $ hGetContents $ ur_stdout r
    dPut [Str $ "\"" ++ (ur_output r) ++ "\" ", Str " Failure (", Str $ show $ ur_exit_code r
        , Str "): ", Ln errors, Ln output, Failure]
    return $ defaultValue $ ur_compilation_args r


  -- most cases can't create an incoherent successful result
  wrongSuccess :: UtilityResult c -> EitherT String IO a
  wrongSuccess = return . defaultValue . ur_compilation_args


  wrongFailure :: UtilityResult c -> EitherT String IO a
  wrongFailure ur = failure $ ur{ur_output = "<no message>"}


  runCU :: c -> EitherT String IO a
  runCU c = do
    catchIO $ do
      putStr $ maybe "" (\x -> "Running " ++ x ++ "...") $ utitle c
      if verbose c then (putStrLn . concat . map (++ "\n")) (executable c:toStringList c) else return ()
    (_, Just stout, Just sterr, phandle) <- catchIO $ createProcess $ shellArgs c
    result <- catchIO $ runEitherT $ analyseProgress c sterr phandle
    exitCode <- catchIO $ waitForProcess phandle
    case exitCode of
      ExitSuccess -> case result of
        Right _ -> success $ UtilityResult c stout sterr 0 ""
        Left msg -> wrongSuccess $ UtilityResult c stout sterr 0 msg
      ExitFailure code -> case result of
        Right _ -> wrongFailure $ UtilityResult c stout sterr code ""
        Left msg -> failure $ UtilityResult c stout sterr code msg