Better support for running scripts.

Cabal/src/Distribution/Types/PackageName/Magic.hs

@@ -11,10 +11,14 @@ import Distribution.Types.Version
 nonExistentPackageThisIsCabalBug :: PackageName
 nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug"
 
--- | Used by @cabal new-repl@ and @cabal new-run@
+-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@
 fakePackageName :: PackageName
 fakePackageName = mkPackageName "fake-package"
 
+-- | Used by @cabal new-run@ and @cabal new-build@
+fakePackageCabalFileName :: FilePath
+fakePackageCabalFileName = "fake-package.cabal"
+
 -- | 'fakePackageName' with 'version0'.
 fakePackageId :: PackageId
 fakePackageId = PackageIdentifier fakePackageName version0

cabal-install/cabal-install.cabal

@@ -159,6 +159,7 @@ library
         Distribution.Client.Sandbox
         Distribution.Client.Sandbox.PackageEnvironment
         Distribution.Client.SavedFlags
+        Distribution.Client.ScriptUtils
         Distribution.Client.Security.DNS
         Distribution.Client.Security.HTTP
         Distribution.Client.Setup

cabal-install/src/Distribution/Client/CmdBuild.hs

@@ -32,6 +32,8 @@ import Distribution.Verbosity
          ( normal )
 import Distribution.Simple.Utils
          ( wrapText, die' )
+import Distribution.Client.ScriptUtils
+         ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )
 
 import qualified Data.Map as Map
 
@@ -95,19 +97,19 @@ defaultBuildFlags = BuildFlags
 -- "Distribution.Client.ProjectOrchestration"
 --
 buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
-buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do
+buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags
+  = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do
     -- TODO: This flags defaults business is ugly
     let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags
                                  <> buildOnlyConfigure buildFlags)
         targetAction
             | onlyConfigure = TargetActionConfigure
             | otherwise = TargetActionBuild
 
-    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
-
-    targetSelectors <-
-      either (reportTargetSelectorProblems verbosity) return
-      =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings
+    baseCtx <- case targetCtx of
+      ProjectContext             -> return ctx
+      GlobalContext              -> return ctx
+      ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
 
     buildCtx <-
       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -141,8 +143,6 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
   where
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags
-                  mempty -- ClientInstallFlags, not needed here
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

cabal-install/src/Distribution/Client/CmdClean.hs

@@ -8,6 +8,8 @@ import Distribution.Client.DistDirLayout
     ( DistDirLayout(..), defaultDistDirLayout )
 import Distribution.Client.ProjectConfig
     ( findProjectRoot )
+import Distribution.Client.ScriptUtils
+    ( getScriptCacheDirectoryRoot )
 import Distribution.Client.Setup
     ( GlobalFlags )
 import Distribution.ReadE ( succeedReadE )
@@ -22,9 +24,14 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
     ( normal )
 
+import Control.Monad
+    ( forM, forM_, mapM )
+import qualified Data.Set as Set
 import System.Directory
     ( removeDirectoryRecursive, removeFile
-    , doesDirectoryExist, getDirectoryContents )
+    , doesDirectoryExist, doesFileExist
+    , getDirectoryContents, listDirectory
+    , canonicalizePath )
 import System.FilePath
     ( (</>) )
 
@@ -80,16 +87,21 @@ cleanAction CleanFlags{..} extraArgs _ = do
         mdistDirectory = flagToMaybe cleanDistDir
         mprojectFile   = flagToMaybe cleanProjectFile
 
-    unless (null extraArgs) $
-        die' verbosity $ "'clean' doesn't take any extra arguments: "
-                         ++ unwords extraArgs
+    -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
+    --
+    -- For now assume all files passed are the names of scripts
+    notScripts <- filterM (fmap not . doesFileExist) extraArgs
+    unless (null notScripts) $
+        die' verbosity $ "'clean' extra arguments should be script files: "
+                         ++ unwords notScripts
 
     projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile
 
     let distLayout = defaultDistDirLayout projectRoot mdistDirectory
 
-    if saveConfig
-        then do
+    -- Do not clean a project if just running a script in it's directory
+    when (null extraArgs || isJust mdistDirectory) $ do
+        if saveConfig then do
             let buildRoot = distBuildRootDirectory distLayout
 
             buildRootExists <- doesDirectoryExist buildRoot
@@ -103,7 +115,24 @@ cleanAction CleanFlags{..} extraArgs _ = do
             info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
             handleDoesNotExist () $ removeDirectoryRecursive distRoot
 
-    removeEnvFiles (distProjectRootDirectory distLayout)
+        removeEnvFiles (distProjectRootDirectory distLayout)
+
+    -- Clean specified script build caches and orphaned caches.
+    -- There is currently no good way to specify to only clean orphaned caches.
+    -- It would be better as part of an explicit gc step (see issue #3333)
+    toClean  <- Set.fromList <$> mapM canonicalizePath extraArgs
+    cacheDir <- getScriptCacheDirectoryRoot
+    existsCD <- doesDirectoryExist cacheDir
+    caches   <- if existsCD then listDirectory cacheDir else return []
+    paths    <- fmap concat . forM caches $ \cache -> do
+        let locFile = cacheDir </> cache </> "scriptlocation"
+        exists <- doesFileExist locFile
+        if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
+    forM_ paths $ \(cache, script) -> do
+        exists <- doesFileExist script
+        when (not exists || script `Set.member` toClean) $ do
+            info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
+            removeDirectoryRecursive cache
 
 removeEnvFiles :: FilePath -> IO ()
 removeEnvFiles dir =