Applicative and Monad wrappers for Command library

gistfile1.hs

import Control.Applicative
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import System.Command

newtype Cmd m a = Cmd { runCmd :: m (Either (ExitCode, String) a) }

cmd :: MonadIO m => FilePath -> [String] -> String -> Cmd m String
cmd prog args stdin = Cmd $ do
  (code, stdout, stderr) <- liftIO $ readProcessWithExitCode prog args stdin
  if isSuccess code then return (Right stdout)
    else return (Left (code, stderr))

instance Functor m => Functor (Cmd m) where
  fmap f (Cmd m) = Cmd (fmap (either Left (Right . f)) m)

instance Applicative m => Applicative (Cmd m) where
  pure = Cmd . pure . Right
  Cmd mf <*> Cmd mx = Cmd (go <$> mf <*> mx)
    where
      go (Left ef)         _ = Left ef
      go (Right _) (Left ex) = Left ex
      go (Right f) (Right x) = Right (f x)

instance Monad m => Monad (Cmd m) where
  return = Cmd . return . Right
  Cmd mx >>= f = Cmd $ do
    x <- mx
    case x of
      Left errx -> return (Left errx)
      Right okx -> runCmd (f okx)

instance MonadTrans Cmd where
  lift = Cmd . liftM Right

instance MonadIO m => MonadIO (Cmd m) where
  liftIO = lift . liftIO

newtype CmdPar m a = CmdPar { runCmdPar :: m (Either [(ExitCode, String)] a) }

cmdPar :: MonadIO m => FilePath -> [String] -> String -> CmdPar m String
cmdPar prog args stdin = CmdPar $ do
  (code, stdout, stderr) <- liftIO $ readProcessWithExitCode prog args stdin
  if isSuccess code then return (Right stdout)
    else return (Left [(code, stderr)])

runPar :: Functor m => CmdPar m a -> Cmd m (Either [(ExitCode, String)] a)
runPar = Cmd . fmap Right . runCmdPar

instance Functor m => Functor (CmdPar m) where
  fmap f (CmdPar m) = CmdPar (fmap (either Left (Right . f)) m)

instance (Applicative m, MonadIO m) => Applicative (CmdPar m) where
  pure = CmdPar . pure . Right
  CmdPar mf <*> CmdPar mx = CmdPar $ do
    (rf, rx) <- liftIO $ do
      vf <- newEmptyMVar
      vx <- newEmptyMVar
      _ <- forkIO (undefined mf >>= putMVar vf)
      _ <- forkIO (undefined mx >>= putMVar vx)
      (,) <$> takeMVar vf <*> takeMVar vx
    case (rf, rx) of
      (Right f, Right x) -> return (Right $ f x)
      (Right _, Left ex) -> return (Left ex)
      (Left ef, Right _) -> return (Left ef)
      (Left ef, Left ex) -> return (Left (ef++ex))