module Zifter.Stack where import Control.Monad import Control.Monad.IO.Class import Data.Function (on) import Data.List (groupBy, intersect, isInfixOf, isPrefixOf, sortOn) import Data.Maybe (mapMaybe) import Path import Path.IO import Safe import System.Exit (ExitCode(..)) import qualified System.FilePath as FP (splitPath) import System.IO import System.Process import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Parse import Distribution.Verbosity import Zifter.Zift stackBuildZift :: Zift () stackBuildZift = do () <- stackCheckAndPrintVersion stackBuild stackCheckAndPrintVersion :: Zift () stackCheckAndPrintVersion = do rd <- getRootDir let cmd = "stack --version" (_, mouth, _, ph) <- liftIO $ createProcess ((shell cmd) {cwd = Just $ toFilePath rd, std_out = CreatePipe}) ec <- liftIO $ waitForProcess ph case mouth of Nothing -> pure () Just outh -> liftIO (hGetContents outh) >>= printZift case ec of ExitFailure c -> fail $ unwords [cmd, "failed with exit code", show c] ExitSuccess -> pure () stackGetPackageTargetTuples :: Zift [(String, [String])] stackGetPackageTargetTuples = do sps <- stackGetPackageTargetTuplesAccordingToStackIDE cps <- stackGetPackageTargetTuplesAccordingToCabalFiles pure $ combine $ uncombine sps `intersect` uncombine cps combine :: Ord a => [(a, b)] -> [(a, [b])] combine = mapMaybe (\tups -> (,) <$> (fst <$> headMay tups) <*> pure (map snd tups)) . groupBy ((==) `on` fst) . sortOn fst uncombine :: Ord a => [(a, [b])] -> [(a, b)] uncombine xs = do (a, bs) <- xs b <- bs pure (a, b) stackGetPackageTargetTuplesAccordingToStackIDE :: Zift [(String, [String])] stackGetPackageTargetTuplesAccordingToStackIDE = do rd <- getRootDir let getErrFrom cmd = do (_, _, merrh, ph) <- liftIO $ createProcess ((shell cmd) {cwd = Just $ toFilePath rd, std_err = CreatePipe}) ec <- liftIO $ waitForProcess ph case ec of ExitFailure c -> fail $ unwords [show cmd, "failed with exit code", show c] ExitSuccess -> pure () case merrh of Nothing -> fail $ unwords ["Failed to capture output of", show cmd] Just outh -> liftIO (hGetContents outh) outt <- getErrFrom "stack ide targets" outp <- getErrFrom "stack ide packages" let targets = lines outt let packages = lines outp pure $ flip map packages $ \t -> (t, filter (isPrefixOf t) targets) stackGetPackageTargetTuplesAccordingToCabalFiles :: Zift [(String, [String])] stackGetPackageTargetTuplesAccordingToCabalFiles = do rd <- getRootDir (_, fs) <- liftIO $ listDirRecur rd let cabalFiles = filter (not . isInfixOf ".stack-work" . toFilePath) $ filter (not . hidden) $ filter ((== ".cabal") . fileExtension) fs (concat <$>) $ forM cabalFiles $ \cabalFile -> do pd <- liftIO $ readPackageDescription deafening $ toFilePath cabalFile let packageDesc = flattenPackageDescription pd name = unPackageName $ pkgName $ package packageDesc libname = name ++ ":lib" lib = case library packageDesc of Nothing -> [] Just _ -> [libname] testnames = map (((name ++ ":test:") ++) . testName) $ testSuites packageDesc pure [(name, lib ++ testnames)] stackBuild :: Zift () stackBuild = do rd <- getRootDir let stack :: String -> Zift () stack args = do let buildCmd = unwords ["stack", args] (_, mouth, merrh, bph) <- liftIO $ createProcess ((shell buildCmd) { cwd = Just $ toFilePath rd , std_out = CreatePipe , std_err = CreatePipe }) bec <- liftIO $ waitForProcess bph case mouth of Nothing -> pure () Just outh -> liftIO (hGetContents outh) >>= printZift case merrh of Nothing -> pure () Just errh -> liftIO (hGetContents errh) >>= printZift case bec of ExitFailure c -> fail $ unwords [buildCmd, "failed with exit code", show c] ExitSuccess -> printPreprocessingDone $ unwords [buildCmd, "succeeded."] tups <- stackGetPackageTargetTuples stack "build" forM_ tups $ \(package_, targets) -> do stack $ unwords ["clean", package_] forM_ targets $ \target -> stack $ unwords [ "build --pedantic --haddock --test" , target , "--test-arguments='--fail-fast --seed=42'" ] hidden :: Path Abs t -> Bool hidden = any ((Just '.' ==) . headMay) . FP.splitPath . toFilePath