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 path args = hPutStrLn stderr $ "TRACE: " ++ unwords ([path] ++ args)
traceCommand _ _ = return ()

-- 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 ()

callProcessFilter :: String -> [String] -> (Handle -> String -> IO ()) -> IO ExitCode
callProcessFilter cmd args action = do
  traceCommand cmd args
  (_, Just out, Just err, pid) <-
    Proc.createProcess $ (Proc.proc cmd args) {
                            Proc.std_out = Proc.CreatePipe
                          , Proc.std_err = Proc.CreatePipe }

  mapM_ (flip hSetBinaryMode False) [out, err]
  mapM_ (flip hSetBuffering LineBuffering) [out, err]

  forM_ [(out, stdout), (err, stderr)] $ \(hin, hout) -> do
    let isError = flip any [IO.isEOFError, IO.isIllegalOperation] . flip ($)
    forkIO $ flip IO.catchIOError (\e -> if isError e then return () else ioError e)
           $ forever $ hGetLine hin >>= action hout

  ec <- Proc.waitForProcess pid

  hClose out
  hClose err

  return ec

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 $ buildDir </> "build" </> exe </> exe

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

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

buildDir :: FilePath
buildDir = "dist"

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

  cabal <- findExecutable "cabal"
  progName <- Env.getProgName
  args <- Env.getArgs

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

  let configureArgs = [
          -- These might be defined in the user's cabal config file and effectively double compilation times
        --   "--disable-library-profiling"
        -- , "--disable-executable-profiling"
        ]
      configure = do
        putStrLn $ progName ++ ": Configuring build system ..."
        callProcess cabal $ ["configure"] ++ configureArgs
      initialize = do
        putStrLn $ progName ++ ": Initializing build system ..."
        callProcess cabal ["sandbox", "init"]
        mapM_ (\dir -> callProcess cabal ["sandbox", "add-source", dir])
              (configPackageDirs config)
        callProcess cabal $ ["install"] ++ configureArgs ++
                            [ "--only-dependencies"
                            , "--force-reinstalls"
                            , "--disable-documentation"
                            , j]
        configure
      update = do
        putStrLn $ progName ++ ": Updating build system ..."

        sandboxExists <- Dir.doesDirectoryExist sandboxDir
        exeExists <- Dir.doesFileExist =<< getBuildCommand cabalFile pkg

        if not sandboxExists
          then initialize
          else if not exeExists
               then configure
               else return ()

        -- Update build executable
        -- When the public interface of package dependencies changes, the local package needs to be reconfigured.
        reconfigure <- newMVar False

        exitCode <- callProcessFilter cabal ["build", j] $ \h line -> do
          hPutStrLn h line
          when (List.isInfixOf "cannot satisfy -package-id" line)
            $ void $ swapMVar reconfigure True

        case exitCode of
          ExitSuccess -> return ()
          ExitFailure code -> do
            b <- readMVar reconfigure
            if b
            then do
              configure
              callProcess cabal ["build", j]
            else execError cabal code

  case args of
    (".init":_) -> do
      -- Initialize sandbox
      initialize
    (".update":_) -> do
      -- Update build command
      update
    (".scrub":_) -> do
      -- Clean everything
      exe <- getBuildCommand cabalFile pkg
      exeExists <- Dir.doesFileExist exe
      when exeExists $ callProcess_ exe ["clean"]
      distExist <- Dir.doesDirectoryExist buildDir
      when distExist $
        Dir.removeDirectoryRecursive buildDir
      hasSandbox <- Dir.doesDirectoryExist sandboxDir
      when hasSandbox $
        callProcess cabal ["sandbox", "delete"]
    (('.':cmd):_) -> do
      hPutStrLn stderr $ "Usage: " ++ progName ++ " .init|.update|.scrub|SHAKE_ARGS..."
      exitFailure
    args -> do
      -- Call build command with arguments
      exe <- getBuildCommand cabalFile pkg
      exeExists <- Dir.doesFileExist exe
      unless exeExists $ update
      callProcess exe (j:args)