Reorganize shared modules

DanielG · Mar 1, 2017 · 460f3cd · 460f3cd
1 parent 6216cbd
commit 460f3cd
Show file tree

Hide file tree

Showing 5 changed files with 61 additions and 4 deletions.
diff --git a/Data/Binary/Generic.hs → core/Data/Binary/Generic.hs b/Data/Binary/Generic.hs → core/Data/Binary/Generic.hs
diff --git 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 → shared/System/Directory/ModTime.hs b/System/Directory/ModTime.hs → shared/System/Directory/ModTime.hs
diff --git a/shared/System/Process/Concurrent.hs 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 → shared/Utils.hs b/Utils.hs → shared/Utils.hs