From 460f3cdc989868d61ce09fc9a42864ee815cff31 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Thu, 9 Feb 2017 13:57:20 +0100
Subject: [PATCH] Reorganize shared modules

---
 {Data => core/Data}/Binary/Generic.hs         |  0
 ghc-mod.cabal                                 |  8 +--
 .../System}/Directory/ModTime.hs              |  0
 shared/System/Process/Concurrent.hs           | 57 +++++++++++++++++++
 Utils.hs => shared/Utils.hs                   |  0
 5 files changed, 61 insertions(+), 4 deletions(-)
 rename {Data => core/Data}/Binary/Generic.hs (100%)
 rename {System => shared/System}/Directory/ModTime.hs (100%)
 create mode 100644 shared/System/Process/Concurrent.hs
 rename Utils.hs => shared/Utils.hs (100%)

diff --git a/Data/Binary/Generic.hs b/core/Data/Binary/Generic.hs
similarity index 100%
rename from Data/Binary/Generic.hs
rename to core/Data/Binary/Generic.hs
diff --git a/ghc-mod.cabal b/ghc-mod.cabal
index 36dac51cd..e27d649d0 100644
--- a/ghc-mod.cabal
+++ b/ghc-mod.cabal
@@ -109,7 +109,7 @@ Library
   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
                         ConstraintKinds, FlexibleContexts,
                         DataKinds, KindSignatures, TypeOperators, ViewPatterns
-  HS-Source-Dirs:       ., core
+  HS-Source-Dirs:       ., core, shared
   Exposed-Modules:
                         GhcMod
                         GhcModExe.Boot
@@ -217,7 +217,7 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCModWrapper.hs
   Other-Modules:        Paths_ghc_mod
-  HS-Source-Dirs:       src, .
+  HS-Source-Dirs:       ., src, shared
   GHC-Options:          -Wall
   Build-Depends:        base      < 5 && >= 4.0
                       , directory < 1.4
@@ -239,7 +239,7 @@ Executable ghc-mod-real
                       , GHCMod.Options.ShellParse
   GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
-  HS-Source-Dirs:       src
+  HS-Source-Dirs:       src, shared
   X-Internal:           True
   Build-Depends:
                         base
@@ -268,7 +268,7 @@ Executable ghc-modi
   if os(windows)
       Cpp-Options:      -DWINDOWS
   Default-Extensions:   ConstraintKinds, FlexibleContexts
-  HS-Source-Dirs:       src, .
+  HS-Source-Dirs:       ., src, shared
   Build-Depends:
                       -- See Note [GHC Boot libraries]
                         base
diff --git a/System/Directory/ModTime.hs b/shared/System/Directory/ModTime.hs
similarity index 100%
rename from System/Directory/ModTime.hs
rename to shared/System/Directory/ModTime.hs
diff --git a/shared/System/Process/Concurrent.hs b/shared/System/Process/Concurrent.hs
new file mode 100644
index 000000000..5f2ba5372
--- /dev/null
+++ b/shared/System/Process/Concurrent.hs
@@ -0,0 +1,57 @@
+module System.Process.Concurrent where
+
+import Control.Concurrent.MVar
+import System.Process
+import System.Exit (ExitCode)
+import System.IO (Handle)
+
+newtype CProcessHandle = CProcessHandle (MVar ProcessHandleState)
+
+data ProcessHandleState = OpenHandle ProcessHandle
+                        | WaitingOn  ProcessHandle (MVar ExitCode)
+                        | ClosedHandle ExitCode
+
+createCProcess :: CreateProcess
+               -> IO ( Maybe Handle
+                     , Maybe Handle
+                     , Maybe Handle
+                     , CProcessHandle
+                     )
+createCProcess p = do
+  (i, o, e, h) <- createProcess p
+  ch <- mkCProcessHandle h
+  return (i, o, e, ch)
+
+mkCProcessHandle :: ProcessHandle -> IO CProcessHandle
+mkCProcessHandle handle =
+  CProcessHandle <$> newMVar (OpenHandle handle)
+
+waitForCProcess :: CProcessHandle -> IO ExitCode
+waitForCProcess (CProcessHandle mv) = do
+  phs <- takeMVar mv
+  -- TODO: What happens when an exception occurs in here?
+  case phs of
+    OpenHandle handle -> do
+        emv <- newEmptyMVar
+        putMVar mv $ WaitingOn handle emv
+        rv <- waitForProcess handle
+        putMVar emv rv
+        return rv
+    WaitingOn _handle emv -> do
+        putMVar mv phs
+        takeMVar emv
+    ClosedHandle rv -> do
+        putMVar mv phs
+        return rv
+
+terminateCProcess :: CProcessHandle -> IO ()
+terminateCProcess (CProcessHandle mv) = do
+  phs <- takeMVar mv
+  case phs of
+    OpenHandle handle -> do
+      terminateProcess handle
+    WaitingOn handle _ -> do
+      terminateProcess handle
+    _ -> return ()
+
+  putMVar mv phs
diff --git a/Utils.hs b/shared/Utils.hs
similarity index 100%
rename from Utils.hs
rename to shared/Utils.hs