{-# LANGUAGE LambdaCase #-} module Main where import Control.Monad (forM_, when) import Data.Function (on) import Data.List (intercalate, groupBy, sortBy) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Ord (comparing) import qualified Distribution.Types.PackageDescription as PD import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.BuildType (BuildType(Simple)) import Options.Applicative (execParser) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Exit (die) import System.FilePath (()) import System.IO (hPutStrLn, stderr) import Coolbal.CabalPlan import Coolbal.Configure (configure) import qualified Coolbal.EnvBinary as B import Coolbal.FindRoot import Coolbal.Options import Coolbal.Target import Coolbal.Target.Class import Coolbal.Target.Executable.Make (makeExeTarget) checkCompatibleSpec :: PackageDescription -> IO () checkCompatibleSpec pd | PD.buildType pd /= Simple = die ("Only build type Simple is supported; package uses " ++ show (PD.buildType pd)) | not (null (PD.setupBuildInfo pd)) = die "Custom setup build info unsupported" | otherwise = return () compatibleTargets :: Flags -> FilePath -> PackageDescription -> CabalPlan -> IO [AnyTarget] compatibleTargets flags projdir pd plan = catMaybes <$> mapM (\e -> fmap AnyTargetExe <$> makeExeTarget flags projdir e plan) (PD.executables pd) parseCabalPlan' :: FoundCabalSpec -> IO CabalPlan parseCabalPlan' foundSpec = parseCabalPlan (foundcsRootDir foundSpec "dist-newstyle/cache/plan.json") >>= \case NotFound -> die "Cabal plan.json not found; make sure to run 'cabal configure' beforehand" ParseError e -> die ("Error when parsing Cabal plan.json: " ++ e) Parsed plan -> return plan readCachedTargets :: (AnyTarget -> Bool) -> IO (FilePath, [AnyTarget], [(String, [AnyTarget])]) readCachedTargets predicate = do FoundRootDir rootdir <- findDist allTargets <- B.decodeFile (RestoreEnv { reProjDir = rootdir }) (rootdir "dist-coolbal/targets.bin") let targets = filter predicate allTargets targetsForName = map ((,) <$> fst . head <*> map snd) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) $ concat [[(useAnyTarget targetName t, t), (useAnyTarget targetNameQualified t, t)] | t <- targets] return (rootdir, targets, targetsForName) targetsToBuild :: [(String, [AnyTarget])] -> String -> IO [AnyTarget] targetsToBuild targetsForName name = case lookup name targetsForName of Nothing -> die ("Target not found: '" ++ name ++ "'") Just [t] -> return [t] Just _ -> die ("Ambiguous target name: '" ++ name ++ "'") doConfigure :: Flags -> IO () doConfigure flags= do foundSpec <- findCabalSpec pd <- configure (foundcsCabal foundSpec) checkCompatibleSpec pd plan <- parseCabalPlan' foundSpec -- print pd targets <- compatibleTargets flags (foundcsRootDir foundSpec) pd plan let names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")")) targets hPutStrLn stderr ("Supported targets: " ++ intercalate ", " names) createDirectoryIfMissing True (foundcsRootDir foundSpec "dist-coolbal") B.encodeFile (foundcsRootDir foundSpec "dist-coolbal/targets.bin") targets doClean :: IO () doClean = do foundSpec <- findCabalSpec removeDirectoryRecursive (foundcsRootDir foundSpec "dist-coolbal") doBuild :: Flags -> BuildOptions -> IO () doBuild flags (BuildOptions mtarget) = do (rootdir, targets, targetsForName) <- readCachedTargets (const True) toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget forM_ toBuild $ useAnyTarget $ \tg -> do old <- targetCheckOld rootdir tg when old $ targetBuild flags tg doRebuild :: Flags -> BuildOptions -> IO () doRebuild flags (BuildOptions mtarget) = do (rootdir, targets, targetsForName) <- readCachedTargets (const True) toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget forM_ toBuild $ useAnyTarget $ \tg -> do targetRemoveBuildArtifacts rootdir tg targetBuild flags tg doRun :: Flags -> RunOptions -> IO () doRun flags (RunOptions mtarget args) = do (rootdir, targets, targetsForName) <- readCachedTargets (isJust . useAnyTarget (targetExecute flags)) toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget case toBuild of [tg] -> do useAnyTarget (\tg' -> do old <- targetCheckOld rootdir tg' when old $ targetBuild flags tg' -- when (not old) $ putStrLn "Up to date" fromJust (targetExecute flags tg') args) tg _ -> do die "Cannot determine which target to run, multiple executables found" main :: IO () main = do Options flags command <- execParser optionParser case command of Configure -> doConfigure flags Clean -> doClean Build opts -> doBuild flags opts Rebuild opts -> doRebuild flags opts Run opts -> doRun flags opts