Commits

Alex Suraci committed caf09b6

initial record
Ignore-this: 314fb9b0dfd1c5684f79e90424751935

Comments (0)

Files changed (2)

+{-# 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 new: (exe: String) with: (args: List)|] =::: [$e|
+        Command clone do:
+          { executable = exe
+            arguments = args
+          }
+    |]
+
+    [$p|(c: Command) run|] =: do
+        exe <- getString [$e|c executable|]
+        args <- fmap (map fromString) $ getList [$e|c arguments|]
+
+        env <-
+            ifE [$e|c responds-to?: @environment|]
+                (do
+                    as <- getList [$e|c environment|]
+                    ps <- forM as $ \p -> do
+                        k <- dispatch (single "from" p)
+                        v <- dispatch (single "to" p)
+                        return (fromString k, fromString v)
+                    return (Just ps))
+                (return Nothing)
+
+        cwd <-
+            ifE [$e|c responds-to?: @working-directory|]
+                (fmap Just (getString [$e|c working-directory|]))
+                (return Nothing)
+
+        sin <-
+            ifE [$e|c responds-to?: @standard-input|]
+                (fmap Just (getHandle [$e|c standard-input handle|]))
+                (return Nothing)
+
+        sout <-
+            ifE [$e|c responds-to?: @standard-output|]
+                (fmap Just (getHandle [$e|c standard-output handle|]))
+                (return Nothing)
+
+        serr <-
+            ifE [$e|c responds-to?: @standard-error|]
+                (fmap Just (getHandle [$e|c standard-error handle|]))
+                (return Nothing)
+
+        ph <- liftIO $ runProcess exe args cwd env sin sout serr
+        newCommand ph
+
+    [$p|(c: Command) run-interactively|] =: do
+        exe <- getString [$e|c executable|]
+        args <- fmap (map fromString) $ getList [$e|c arguments|]
+
+        env <-
+            ifE [$e|c responds-to?: @environment|]
+                (do
+                    as <- getList [$e|c environment|]
+                    ps <- forM as $ \p -> do
+                        k <- dispatch (single "from" p)
+                        v <- dispatch (single "to" p)
+                        return (fromString k, fromString v)
+                    return (Just ps))
+                (return Nothing)
+
+        cwd <-
+            ifE [$e|c responds-to?: @working-directory|]
+                (fmap Just (getString [$e|c working-directory|]))
+                (return Nothing)
+
+        (sin, sout, serr, h) <- liftIO (runInteractiveProcess exe args cwd env)
+        newInteractiveCommand (sin, sout, serr) h
+
+    [$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"
+    getHandle e = eval e >>= fromHaskell "Handle"
+
+    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"
+
+name: "command"
+description: "interface to System.Process"
+version: 0 . 1
+author: "Alex Suraci"