Fix commercialhaskell#5755 Add --force-script-no-run-compile flag

Adds a `--force-script-no-run-compile` flag (disabled by default) that forces the `--no-run` and `--compile` options with `stack script`.

This enables a command like `stack --force-script-no-run-compile Script.hs` to behave like `stack script ... --no-run --compile -- Script.hs` but without having to list all the other arguments in the stack interpreter options comment (represented by `...`) on the command line.

src/Stack/Config.hs

@@ -342,6 +342,7 @@ configFromConfigMonoid
          configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl
          configHideSourcePaths = fromFirstTrue configMonoidHideSourcePaths
          configRecommendUpgrade = fromFirstTrue configMonoidRecommendUpgrade
+         configForceNoRunCompile = fromFirstFalse configMonoidForceNoRunCompile
 
      configAllowDifferentUser <-
         case getFirst configMonoidAllowDifferentUser of

src/Stack/Options/ConfigParser.hs

@@ -23,7 +23,7 @@ configOptsParser currentDir hide0 =
     (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch
         ghcVariant ghcBuild jobs includes libs preprocs overrideGccPath overrideHpack
         skipGHCCheck skipMsys localBin setupInfoLocations modifyCodePage
-        allowDifferentUser dumpLogs colorWhen snapLoc -> mempty
+        allowDifferentUser dumpLogs colorWhen snapLoc forceNoRunCompile -> mempty
             { configMonoidStackRoot = stackRoot
             , configMonoidWorkDir = workDir
             , configMonoidBuildOpts = buildOpts
@@ -49,6 +49,7 @@ configOptsParser currentDir hide0 =
             , configMonoidDumpLogs = dumpLogs
             , configMonoidColorWhen = colorWhen
             , configMonoidSnapshotLocation = snapLoc
+            , configMonoidForceNoRunCompile = forceNoRunCompile
             })
     <$> optionalFirst (absDirOption
             ( long stackRootOptionName
@@ -175,6 +176,10 @@ configOptsParser currentDir hide0 =
            <> help "The base location of LTS/Nightly snapshots"
            <> metavar "URL"
             ))
+    <*> firstBoolFlagsFalse
+            "force-script-no-run-compile"
+            "forcing the options `--no-run --compile` with `stack script`"
+            hide
   where
     hide = hideMods (hide0 /= OuterGlobalOpts)
     toDumpLogs (First (Just True)) = First (Just DumpAllLogs)

src/Stack/Script.hs

@@ -75,45 +75,54 @@ scriptCmd opts = do
       SYLNoProject _ -> assert False (return ())
 
     file <- resolveFile' $ soFile opts
+
+    isForceNoRunCompile <- fromFirstFalse . configMonoidForceNoRunCompile <$>
+                             view (globalOptsL.to globalConfigMonoid)
+
     let scriptDir = parent file
         modifyGO go = go
             { globalConfigMonoid = (globalConfigMonoid go)
                 { configMonoidInstallGHC = FirstTrue $ Just True
                 }
             , globalStackYaml = SYLNoProject $ soScriptExtraDeps opts
             }
+        (shouldRun, shouldCompile) = if isForceNoRunCompile
+          then (NoRun, SECompile)
+          else (soShouldRun opts, soCompile opts)
 
-    case soShouldRun opts of
+    case shouldRun of
       YesRun -> pure ()
       NoRun -> do
         unless (null $ soArgs opts) $ throwString "--no-run incompatible with arguments"
-        case soCompile opts of
+        case shouldCompile of
           SEInterpret -> throwString "--no-run requires either --compile or --optimize"
           SECompile -> pure ()
           SEOptimize -> pure ()
 
     -- Optimization: if we're compiling, and the executable is newer
     -- than the source file, run it immediately.
     local (over globalOptsL modifyGO) $
-      case soCompile opts of
-        SEInterpret -> longWay file scriptDir
-        SECompile -> shortCut file scriptDir
-        SEOptimize -> shortCut file scriptDir
+      case shouldCompile of
+        SEInterpret -> longWay shouldRun shouldCompile file scriptDir
+        SECompile -> shortCut shouldRun shouldCompile file scriptDir
+        SEOptimize -> shortCut shouldRun shouldCompile file scriptDir
 
   where
-  runCompiled file = do
+  runCompiled shouldRun file = do
     let exeName = toExeName $ toFilePath file
-    case soShouldRun opts of
+    case shouldRun of
       YesRun -> exec exeName (soArgs opts)
       NoRun -> logInfo $ "Compilation finished, executable available at " <> fromString exeName
-  shortCut file scriptDir = handleIO (const $ longWay file scriptDir) $ do
-    srcMod <- getModificationTime file
-    exeMod <- Dir.getModificationTime $ toExeName $ toFilePath file
-    if srcMod < exeMod
-      then runCompiled file
-      else longWay file scriptDir
+
+  shortCut shouldRun shouldCompile file scriptDir =
+    handleIO (const $ longWay shouldRun shouldCompile file scriptDir) $ do
+      srcMod <- getModificationTime file
+      exeMod <- Dir.getModificationTime $ toExeName $ toFilePath file
+      if srcMod < exeMod
+        then runCompiled shouldRun file
+        else longWay shouldRun shouldCompile file scriptDir
 
-  longWay file scriptDir =
+  longWay shouldRun shouldCompile file scriptDir =
     withConfig YesReexec $
     withDefaultEnvConfig $ do
       config <- view configL
@@ -159,13 +168,13 @@ scriptCmd opts = do
                     $ Set.toList
                     $ Set.insert "base"
                     $ Set.map packageNameString targetsSet
-                , case soCompile opts of
+                , case shouldCompile of
                     SEInterpret -> []
                     SECompile -> []
                     SEOptimize -> ["-O2"]
                 , soGhcOptions opts
                 ]
-        case soCompile opts of
+        case shouldCompile of
           SEInterpret -> do
             interpret <- view $ compilerPathsL.to cpInterpreter
             exec (toFilePath interpret)
@@ -181,7 +190,7 @@ scriptCmd opts = do
               compilerExeName
               (ghcArgs ++ [toFilePath file])
               (void . readProcessStdout_)
-            runCompiled file
+            runCompiled shouldRun file
 
   toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse
 

src/Stack/Types/Config.hs

@@ -381,6 +381,8 @@ data Config =
          -- ^ Enable GHC hiding source paths?
          ,configRecommendUpgrade    :: !Bool
          -- ^ Recommend a Stack upgrade?
+         ,configForceNoRunCompile   :: !Bool
+         -- ^ Force --no-run and --compile options when using `stack script`
          ,configStackDeveloperMode  :: !Bool
          -- ^ Turn on Stack developer mode for additional messages?
          }
@@ -867,6 +869,8 @@ data ConfigMonoid =
     , configMonoidCasaRepoPrefix     :: !(First CasaRepoPrefix)
     , configMonoidSnapshotLocation :: !(First Text)
     -- ^ Custom location of LTS/Nightly snapshots
+    , configMonoidForceNoRunCompile  :: !FirstFalse
+    -- ^ See: 'configForceNoRunCompile'
     , configMonoidStackDeveloperMode :: !(First Bool)
     -- ^ See 'configStackDeveloperMode'
     }
@@ -991,6 +995,7 @@ parseConfigMonoidObject rootDir obj = do
 
     configMonoidCasaRepoPrefix <- First <$> obj ..:? configMonoidCasaRepoPrefixName
     configMonoidSnapshotLocation <- First <$> obj ..:? configMonoidSnapshotLocationName
+    configMonoidForceNoRunCompile <- FirstFalse <$> obj ..:? configMonoidForceNoRunCompileName
 
     configMonoidStackDeveloperMode <- First <$> obj ..:? configMonoidStackDeveloperModeName
 
@@ -1152,6 +1157,9 @@ configMonoidCasaRepoPrefixName = "casa-repo-prefix"
 configMonoidSnapshotLocationName :: Text
 configMonoidSnapshotLocationName = "snapshot-location-base"
 
+configMonoidForceNoRunCompileName :: Text
+configMonoidForceNoRunCompileName = "force-script-no-run-compile"
+
 configMonoidStackDeveloperModeName :: Text
 configMonoidStackDeveloperModeName = "stack-developer-mode"