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

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

type OutputWrapper = IO () -> IO ()

data OutStreamType = Stderr | Stdout

color :: OutStreamType -> String
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 $ do
            putStrLn $
              "\x1b[35m" ++ jobName ++ "\x1b[m " ++
              "\x1b[" ++ (color streamType) ++ "m" ++ line ++ "\x1b[m"

    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
    withOutput $
        putStrLn $ "\x1b[35m" ++ jobName ++ "\x1b[m exit: " ++ 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)