virthualenv-0.2: src/Process.hs

module Process ( externalGhcPkgDb
               , outsideGhcPkg
               , insideGhcPkg
               , runProcess
               , ghcPkgDbPathLocation
               ) where

import Types
import MyMonad
import Paths

import Util.IO (readProcessWithExitCodeInEnv, Environment)

import Control.Monad (forM_)
import Data.Maybe (fromMaybe)
import System.FilePath ((</>))
import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..))

runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String
runProcess env prog args input = do
  debug $ unwords $ ["Executing:", prog] ++ args
  indentMessages $ case env of
    Nothing   -> trace "using inherited variable environment"
    Just env' -> do
      trace "using following environment:"
      indentMessages $ forM_ env' $ \(var,val) -> trace $ var ++ ": " ++ val
  indentMessages $ case input of
    Nothing  -> return ()
    Just inp -> do
      trace "using the following input:"
      indentMessages $ forM_ (lines inp) trace
  let execProcess = case env of
                      Nothing   -> readProcessWithExitCode prog args (fromMaybe "" input)
                      Just env' -> readProcessWithExitCodeInEnv env' prog args input
  (exitCode, output, errors) <- liftIO execProcess
  indentMessages $ debug $ case exitCode of
    ExitSuccess         -> "Process exited successfully"
    ExitFailure errCode -> "Process failed with exit code " ++ show errCode
  indentMessages $ do
    trace "Process output:"
    indentMessages $ forM_ (lines output) trace
  indentMessages $ do
    trace "Process error output:"
    indentMessages $ forM_ (lines errors) trace
  case exitCode of
    ExitSuccess         -> return output
    ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode

-- run outside ghc-pkg tool (uses system's or from ghc installed from tarball)
outsideGhcPkg :: [String] -> MyMonad String
outsideGhcPkg args = do
  ghc <- asks ghcSource
  dirStructure <- vheDirStructure
  ghcPkg <- case ghc of
    System    -> do
      debug "Running system's version of ghc-pkg"
      return "ghc-pkg"
    Tarball _ -> do
      debug "Running ghc-pkg installed from GHC's tarball"
      return $ ghcDir dirStructure </> "bin" </> "ghc-pkg"
  indentMessages $ runProcess Nothing ghcPkg args Nothing

-- returns path to GHC (installed from tarball) builtin package database
externalGhcPkgDb :: MyMonad FilePath
externalGhcPkgDb = do
  debug "Checking where GHC (installed from tarball) keeps its package database"
  out <- indentMessages $ outsideGhcPkg ["list"]
  indentMessages $ debug "Trying to parse ghc-pkg's output"
  case lines out of
    []             -> throwError $ MyException "ghc-pkg returned empty output"
    lineWithPath:_ ->
      case lineWithPath of
        "" -> throwError $ MyException "ghc-pkg's first line of output is empty"
        _  -> do
          -- ghc-pkg ends pkg db path with trailing colon
          -- but only when not run from the terminal
          let path = init lineWithPath
          indentMessages $ debug $ "Found: " ++ path
          return path

-- run ghc-pkg tool (uses system's or from ghc installed from tarball)
-- from the inside of Virtual Haskell Environment
insideGhcPkg :: [String] -> Maybe String -> MyMonad String
insideGhcPkg args input = do
  ghc <- asks ghcSource
  dirStructure <- vheDirStructure
  env <- getVirtualEnvironment
  ghcPkg <- case ghc of
    System    -> do
      debug "Running system's version of ghc-pkg inside virtual environment"
      return "ghc-pkg"
    Tarball _ -> do
      debug "Running ghc-pkg, installed from GHC's tarball, inside virtual environment"
      return $ ghcDir dirStructure </> "bin" </> "ghc-pkg"
  indentMessages $ runProcess (Just env) ghcPkg args input

-- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment
ghcPkgDbPathLocation :: MyMonad String
ghcPkgDbPathLocation = do
  debug "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment"
  dirStructure <- vheDirStructure
  ghc <- asks ghcSource
  case ghc of
    System    -> return $ ghcPackagePath dirStructure
    Tarball _ -> do
             externalGhcPkgDbPath <- indentMessages externalGhcPkgDb
             return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath