{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Process
    ( spawn
    , module System.Process
    ) where

import Control.Concurrent
import Control.Monad (unless, when)
import Data.Monoid
import System.Exit
import System.IO
import System.Process

import Trammel


type OutputWrapper = IO () -> IO ()

data OutStreamType = Stderr | Stdout

color :: OutStreamType -> Ps
color Stderr = 31
color Stdout = 32

data ReaperConfig = ReaperConfig
    { withOutput :: OutputWrapper
    , jobName :: String
    , openFdsRef :: MVar Int
    , processHandle :: ProcessHandle
    , streamHandle :: Handle
    , streamType :: OutStreamType
    }


spawn :: Int -> OutputWrapper -> String -> IO ()
spawn jobId _withOutput cmdline = do

    -- TODO stdin
    (Nothing, Just hOut, Just hErr, ph) <-
        createProcess (shell cmdline)
            { std_in = Inherit -- TODO close
            , std_out = CreatePipe
            , std_err = CreatePipe
            }

    _openFdsRef <- newMVar 2

    let rcOut = ReaperConfig
          { streamType = Stdout
          , streamHandle = hOut
          , withOutput = _withOutput
          , jobName = '&' : show jobId
          , openFdsRef = _openFdsRef
          , processHandle = ph
          }
        rcErr = rcOut
          { streamType = Stderr
          , streamHandle = hErr
          } 

    forkIO $ reap rcOut
    reap rcErr


reap :: ReaperConfig -> IO ()
reap rc@ReaperConfig{..} = do
    forLines_ streamHandle $ \line ->
        withOutput $ putStrLn $ pp $
            SGR [35] (Plain jobName) <>
            Plain " " <>
            SGR [color streamType] (Plain line)

    i <- decMVar openFdsRef

    --withOutput $
    --    putStrLn $ "\x1b[35m" ++ name ++ "\x1b[m eof"

    when (i == 0) $ finish rc

    hClose streamHandle
    myThreadId >>= killThread


finish :: ReaperConfig -> IO ()
finish ReaperConfig{..} = do
    exitCode <- waitForProcess processHandle
    when (exitCode /= ExitSuccess) $
        withOutput $ putStrLn $ pp $
            SGR [35] (Plain jobName) <>
            Plain " " <>
            SGR [31] (Plain $ show exitCode)


decMVar :: MVar Int -> IO Int
decMVar =
    flip modifyMVar dec
  where
    dec i = let i' = i - 1 in return (i', i')
 


-- TODO move utilities somewhere else
forLines_ :: Handle -> (String -> IO ()) -> IO ()
forLines_ h f = rec
  where
    rec = hIsEOF h >>= flip unless (hGetLine h >>= f >> rec)