shake

#!/usr/bin/env runhaskell +RTS -I0 -RTS
{-# OPTIONS_GHC  -with-rtsopts=-I0 -threaded -rtsopts #-}

-- Copyright 2013-2014 Samplecount S.L.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.MVar
import           Control.Monad
import           Data.Char (toLower)
import qualified Data.List as List
import qualified Distribution.PackageDescription as Dist
import qualified Distribution.PackageDescription.Configuration as Dist
import qualified Distribution.PackageDescription.Parse as Dist
import qualified Distribution.Verbosity as Dist
import           GHC.Conc (getNumProcessors)
import qualified System.Directory as Dir
import qualified System.Environment as Env
import           System.Exit (ExitCode(..), exitFailure)
import           System.FilePath
import           System.IO
import qualified System.IO.Error as IO
import qualified System.Process as Proc

-- Cabal configuration fields:

configFieldPackageDirs :: String
configFieldPackageDirs = "x-shake-package-dirs"

-- Process utilities

execError :: FilePath -> Int -> IO ()
execError path code = error $ takeFileName path ++ " failed with exit code " ++ show code

checkExitCode :: FilePath -> ExitCode -> IO ()
checkExitCode _ ExitSuccess = return ()
checkExitCode path (ExitFailure code) = execError path code

traceCommand :: String -> [String] -> IO ()
traceCommand path args = do
  debug <- Env.lookupEnv "SHAKE_CABAL_BUILD_DEBUG"
  case debug of
    Nothing -> return ()
    Just _ -> hPutStrLn stderr $ "TRACE: " ++ unwords ([path] ++ args)

-- Not yet in process-1.1
callProcess :: String -> [String] -> IO ()
callProcess path args = do
  traceCommand path args
  Proc.rawSystem path args >>= checkExitCode path

-- Ignore exit code
callProcess_ :: String -> [String] -> IO ()
callProcess_ path args = do
  traceCommand path args
  _ <- Proc.rawSystem path args
  return ()

findExecutable :: String -> IO FilePath
findExecutable exe = maybe (error $ exe ++ " executable not found") id
                        <$> Dir.findExecutable exe

getCabalFile :: IO (FilePath, Dist.PackageDescription)
getCabalFile = do
  cabalFiles <- filter (List.isSuffixOf ".cabal")
                  <$> Dir.getDirectoryContents "."
  case cabalFiles of
    [] -> error "No cabal file found"
    (_:_:_) -> error $ "Multiple cabal files found: " ++ List.intercalate ", " cabalFiles
    [cabalFile] -> do
        pkg <- Dist.flattenPackageDescription
                <$> Dist.readPackageDescription Dist.silent cabalFile
        return (cabalFile, pkg)

getBuildCommand :: FilePath -> Dist.PackageDescription -> IO FilePath
getBuildCommand cabalFile pkg =
  case Dist.executables pkg of
    [] -> error $ "No executables found in " ++ cabalFile
    (spec:rest) -> do
      let exe = Dist.exeName spec
      when (not (null rest)) $
        hPutStrLn stderr $ "Multiple executables found in " ++ cabalFile ++ ", using " ++ exe
      return $ ".cabal-sandbox/bin" </> exe

configPackageDirs :: [(String, String)] -> [FilePath]
configPackageDirs = maybe [] id
                  . fmap lines
                  . lookup configFieldPackageDirs

sandboxDir :: FilePath
sandboxDir = ".cabal-sandbox"

main :: IO ()
main = do
  (cabalFile, pkg) <- getCabalFile
  let config = Dist.customFieldsPD pkg

  progName <- Env.getProgName
  let logLine msg = putStrLn $ progName ++ ": " ++ msg

  cabalExe <- findExecutable "cabal"
  let cabal cmd args = callProcess cabalExe (cmd:args)

  j <- (("-j"++) . show) <$> getNumProcessors

  let update = do
        logLine "Updating build system ..."
        cabal "sandbox" ["init"]
        mapM_ (\dir -> cabal "sandbox" ["add-source", dir])
              (configPackageDirs config)
        cabal "install" [ "--force-reinstalls"
                        , "--disable-library-profiling"
                        , "--disable-executable-profiling"
                        , "--disable-documentation"
                        , j ]

  args <- Env.getArgs

  case args of
    (".update":_) -> do
      -- Update build script and dependencies
      update
    (".repl":_) -> do
      -- Load build script in ghci
      cabal "repl" []
    (".scrub":_) -> do
      -- Clean everything
      exe <- getBuildCommand cabalFile pkg
      exeExists <- Dir.doesFileExist exe
      when exeExists $ callProcess_ exe ["clean"]
      hasSandbox <- Dir.doesDirectoryExist sandboxDir
      when hasSandbox $
        cabal "sandbox" ["delete"]
    (('.':cmd):_) -> do
      hPutStrLn stderr $ "Usage: " ++ progName ++ " .update|.repl|.scrub|SHAKE_ARGS..."
      exitFailure
    shakeArgs -> do
      -- Call build command with arguments
      exe <- getBuildCommand cabalFile pkg
      exeExists <- Dir.doesFileExist exe
      unless exeExists $ update
      callProcess exe (j:shakeArgs)