atomo command-line stuff

process.hs

{-# LANGUAGE QuasiQuotes, StandaloneDeriving, DeriveDataTypeable #-}

import Atomo.Environment
import Atomo.Haskell

import Data.Typeable
import System.Exit
import System.Process

deriving instance Typeable ProcessHandle


load :: VM ()
load = do
    ([$p|Command|] =::) =<< eval [$e|Object clone|]

    [$p|Command run: (cmd: String)|] =: do
        cmd <- getString [$e|cmd|]
        ph <- liftIO (runCommand cmd)
        newCommand ph

    [$p|Command run-interactively: (cmd: String)|] =: do
        cmd <- getString [$e|cmd|]
        (sin, sout, serr, h) <- liftIO (runInteractiveCommand cmd)
        newInteractiveCommand (sin, sout, serr) h

    [$p|(c: Command) wait|] =:
        getPH [$e|c handle|]
            >>= liftIO . waitForProcess
            >>= return . toExit

    [$p|(c: Command) exit-status|] =:
        getPH [$e|c handle|]
            >>= liftIO . getProcessExitCode
            >>= return . maybe
                    (particle "running")
                    (\ec -> keyParticleN ["done"] [toExit ec])

    [$p|(c: Command) terminate|] =:
        getPH [$e|c handle|]
            >>= liftIO . terminateProcess
            >> return (particle "ok")
  where
    getPH e = eval e >>= fromHaskell "ProcessHandle"

    toExit ExitSuccess = particle "success"
    toExit (ExitFailure i) =
        keyParticleN ["failure"] [Integer (fromIntegral i)]

    newCommand h = do
        proc <- eval [$e|Command clone|]
        [$p|p|] =:: proc
        [$p|p handle|] =:: haskell h
        here "p"

    newInteractiveCommand (sin, sout, serr) h = do
        proc <- eval [$e|Command clone|]
        [$p|p|] =:: proc
        [$p|p handle|] =:: haskell h
        ([$p|p standard-input|] =::) =<< portObj sin
        ([$p|p standard-output|] =::) =<< portObj sout
        ([$p|p standard-error|] =::) =<< portObj serr
        here "p"

    portObj hdl = newScope $ do
        port <- eval [$e|Port clone|]
        [$p|p|] =:: port
        [$p|p handle|] =:: haskell hdl
        here "p"