hdevtools-0.1.8.0: src/Stack.hs

{-# LANGUAGE CPP #-}
module Stack
      ( -- * The bits of information needed from `stack`
        StackConfig (..)
      , findStackYaml
      , getStackConfig
      ) where

import Data.Char (isSpace)

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative((<$>), (<*>))
import System.IO
#endif

import System.Process
import System.FilePath
import System.Directory
import Control.Monad (filterM)
import Control.Exception
import Types

-- TODO: Move into Types?
data StackConfig = StackConfig { stackYaml :: FilePath
                               , stackDist :: FilePath
                               , stackDbs  :: [FilePath]
                               , stackGhcBinDir :: FilePath
                               , stackGhcLibDir :: FilePath
                               }
                   deriving (Eq, Show)

-- | Search for a @stack.yaml@ upwards in given file path tree.
findStackYaml :: FilePath -> IO (Maybe FilePath)
findStackYaml = fmap (fmap trim) . execStackInPath "path --config-location"

-- | Run @stack path@ to compute @StackConfig@
getStackConfig :: CommandExtra -> IO (Maybe StackConfig)
getStackConfig CommandExtra { ceStackYamlPath = Nothing } = return Nothing
getStackConfig CommandExtra { ceStackYamlPath = Just p } = do
    dbs <- getStackDbs root
    dist <- getStackDist root
    ghcBinDir <- getStackGhcBinDir root
    ghcLibDir <- getStackGhcLibDir root
    return $ StackConfig p <$> dist
                           <*> dbs
                           <*> ghcBinDir
                           <*> ghcLibDir
  where
    root = takeDirectory p

getStackGhcBinDir :: FilePath -> IO (Maybe FilePath)
getStackGhcBinDir = fmap (fmap trim) . execStackInPath "path --compiler-bin"

getStackGhcLibDir :: FilePath -> IO (Maybe FilePath)
getStackGhcLibDir p = do
    ghc <- (trim <$>) <$> execStackInPath "path --compiler-exe" p
    case ghc of
        Just exe -> (trim <$>) <$> execInPath (exe ++ " --print-libdir") p
        Nothing -> return Nothing

getStackDist :: FilePath -> IO (Maybe FilePath)
getStackDist p = (trim <$>) <$> execStackInPath "path --dist-dir" p

getStackDbs :: FilePath -> IO (Maybe [FilePath])
getStackDbs p =
  execStackInPath "path --ghc-package-path" p >>=
  maybe (return Nothing) (fmap return . extractDbs)

extractDbs :: String -> IO [FilePath]
extractDbs = filterM doesDirectoryExist . stringPaths

stringPaths :: String -> [String]
stringPaths = splitBy ':' . trim

--------------------------------------------------------------------------------
-- | Generic Helpers
--------------------------------------------------------------------------------

splitBy :: Char -> String -> [String]
splitBy c str
  | null str' = [x]
  | otherwise = x : splitBy c (tail str')
  where
    (x, str') = span (c /=) str

trim :: String -> String
trim = f . f
   where
     f = reverse . dropWhile isSpace

-- Execute stack command in path (if stack is available)
execStackInPath :: String -> FilePath -> IO (Maybe String)
execStackInPath a p =
  findExecutable "stack" >>= maybe (return Nothing) (const $ execInPath ("stack " ++ a) p)

#if __GLASGOW_HASKELL__ < 709
execInPath :: String -> FilePath -> IO (Maybe String)
execInPath cmd p = do
    eIOEstr <- try $ createProcess prc :: IO (Either IOError ProcH)
    case eIOEstr of
        Right (_, Just h, _, _)  -> Just <$> getClose h
        Right (_, Nothing, _, _) -> return Nothing
        -- This error is most likely "/bin/sh: stack: command not found"
        -- which is caused by the package containing a stack.yaml file but
        -- no stack command is in the PATH.
        Left _  -> return Nothing
  where
    prc          = (shell cmd) { cwd = Just $ takeDirectory p }

getClose :: Handle -> IO String
getClose h = do
  str <- hGetContents h
  hClose h
  return str

type ProcH = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

-- Not deleting this because this is likely more robust than the above! (but
-- only works on process-1.2.3.0 onwards

#else
execInPath :: String -> FilePath -> IO (Maybe String)
execInPath cmd p = do
    eIOEstr <- try $ readCreateProcess prc "" :: IO (Either IOError String)
    return $ case eIOEstr of
        Right s -> Just s
        -- This error is most likely "/bin/sh: stack: command not found"
        -- which is caused by the package containing a stack.yaml file but
        -- no stack command is in the PATH.
        Left _  -> Nothing
  where
    prc          = (shell cmd) { cwd = Just p }
#endif