Merge pull request #6454 from commercialhaskell/sundry-prefix

Remove prefixes from field names of various types

Author: mpilgrem

.stan.toml

@@ -43,24 +43,24 @@
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-523:30"
+  id = "OBS-STAN-0102-luLR/n-524:30"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #
-#  522 ┃
-#  523 ┃   let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f
-#  524 ┃                              ^^^^^^^^^^^^^^
+#  523 ┃
+#  524 ┃   let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f
+#  525 ┃                              ^^^^^^^^^^^^^^
 
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-523:65"
+  id = "OBS-STAN-0102-luLR/n-524:65"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #
-#  522 ┃
-#  523 ┃   let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f
-#  524 ┃                                                                 ^^^^^^^^^^^^^^
+#  523 ┃
+#  524 ┃   let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f
+#  525 ┃                                                                 ^^^^^^^^^^^^^^
 
 # Infinite: base/length
 # Usage of the 'length' function that hangs on infinite lists
@@ -116,14 +116,14 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-axv1UG-353:32"
+  id = "OBS-STAN-0203-axv1UG-354:32"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Docker.hs
 #
-#  352 ┃
-#  353 ┃     hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
-#  354 ┃                                ^^^^^^^
+#  353 ┃
+#  354 ┃     hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
+#  355 ┃                                ^^^^^^^
 
 # Data types with non-strict fields
 # Defining lazy fields in data types can lead to unexpected space leaks

package.yaml

@@ -279,7 +279,6 @@ library:
   - Stack.Types.BuildOpts
   - Stack.Types.BuildOptsCLI
   - Stack.Types.BuildOptsMonoid
-
   - Stack.Types.CabalConfigKey
   - Stack.Types.Cache
   - Stack.Types.Casa
@@ -299,6 +298,7 @@ library:
   - Stack.Types.DependencyTree
   - Stack.Types.Docker
   - Stack.Types.DockerEntrypoint
+  - Stack.Types.DotConfig
   - Stack.Types.DotOpts
   - Stack.Types.DownloadInfo
   - Stack.Types.DumpLogs

src/Stack/Coverage.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE NoFieldSelectors      #-}
 {-# LANGUAGE OverloadedRecordDot   #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
@@ -102,20 +103,20 @@ instance Exception CoveragePrettyException
 
 -- | Type representing command line options for the @stack hpc report@ command.
 data HpcReportOpts = HpcReportOpts
-  { hroptsInputs :: [Text]
-  , hroptsAll :: Bool
-  , hroptsDestDir :: Maybe String
-  , hroptsOpenBrowser :: Bool
+  { inputs :: [Text]
+  , all :: Bool
+  , destDir :: Maybe String
+  , openBrowser :: Bool
   }
   deriving Show
 
 -- | Function underlying the @stack hpc report@ command.
 hpcReportCmd :: HpcReportOpts -> RIO Runner ()
 hpcReportCmd hropts = do
   let (tixFiles, targetNames) =
-        L.partition (".tix" `T.isSuffixOf`) hropts.hroptsInputs
+        L.partition (".tix" `T.isSuffixOf`) hropts.inputs
       boptsCLI = defaultBuildOptsCLI
-        { targetsCLI = if hropts.hroptsAll then [] else targetNames }
+        { targetsCLI = if hropts.all then [] else targetNames }
   withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $
     generateHpcReportForTargets hropts tixFiles targetNames
 
@@ -363,10 +364,10 @@ generateHpcReportForTargets opts tixFiles targetNames = do
   targetTixFiles <-
     -- When there aren't any package component arguments, and --all
     -- isn't passed, default to not considering any targets.
-    if not opts.hroptsAll && null targetNames
+    if not opts.all && null targetNames
     then pure []
     else do
-      when (opts.hroptsAll && not (null targetNames)) $
+      when (opts.all && not (null targetNames)) $
         prettyWarnL
           $ "Since"
           : style Shell "--all"
@@ -404,7 +405,7 @@ generateHpcReportForTargets opts tixFiles targetNames = do
     mapM (resolveFile' . T.unpack) tixFiles
   when (null tixPaths) $ prettyThrowIO NoTargetsOrTixSpecified
   outputDir <- hpcReportDir
-  reportDir <- case opts.hroptsDestDir of
+  reportDir <- case opts.destDir of
     Nothing -> pure (outputDir </> relDirCombined </> relDirCustom)
     Just destDir -> do
       dest <- resolveDir' destDir
@@ -414,7 +415,7 @@ generateHpcReportForTargets opts tixFiles targetNames = do
       reportHtml = "combined coverage report"
   mreportPath <- generateUnionReport report reportHtml reportDir tixPaths
   forM_ mreportPath $ \reportPath ->
-    if opts.hroptsOpenBrowser
+    if opts.openBrowser
       then do
         prettyInfo $ "Opening" <+> pretty reportPath <+> "in the browser."
         void $ liftIO $ openBrowser (toFilePath reportPath)

src/Stack/DependencyGraph.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors      #-}
 {-# LANGUAGE OverloadedRecordDot   #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
@@ -19,7 +20,6 @@ import           Distribution.License ( License (..) )
 import qualified Distribution.PackageDescription as PD
 import           Distribution.Types.PackageName ( mkPackageName )
 import           Path ( parent )
-import           RIO.Process ( HasProcessContext (..) )
 import           Stack.Build ( loadPackage )
 import           Stack.Build.Installed ( getInstalled, toInstallMap )
 import           Stack.Build.Source
@@ -41,18 +41,16 @@ import           Stack.Types.BuildOptsCLI
 import           Stack.Types.BuildOptsMonoid
                    ( buildOptsMonoidBenchmarksL, buildOptsMonoidTestsL )
 import           Stack.Types.Compiler ( wantedToActual )
-import           Stack.Types.Config ( HasConfig (..) )
 import           Stack.Types.DependencyTree ( DotPayload (..) )
+import           Stack.Types.DotConfig ( DotConfig (..) )
 import           Stack.Types.DotOpts ( DotOpts (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
 import           Stack.Types.EnvConfig ( EnvConfig (..), HasSourceMap (..) )
-import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
 import           Stack.Types.GhcPkgId
                    ( GhcPkgId, ghcPkgIdString, parseGhcPkgId )
 import           Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL )
 import           Stack.Types.Package ( LocalPackage (..) )
-import           Stack.Types.Platform ( HasPlatform (..) )
-import           Stack.Types.Runner ( HasRunner (..), Runner, globalOptsL )
+import           Stack.Types.Runner ( Runner, globalOptsL )
 import           Stack.Types.SourceMap
                    ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                    , SMActual (..), SMWanted (..), SourceMap (..)
@@ -109,15 +107,15 @@ withDotConfig opts inner =
       else withConfig YesReexec withReal
  where
   withGlobalHints = do
-    bconfig <- view buildConfigL
-    globals <- globalsFromHints bconfig.smWanted.compiler
+    buildConfig <- view buildConfigL
+    globals <- globalsFromHints buildConfig.smWanted.compiler
     fakeGhcPkgId <- parseGhcPkgId "ignored"
     actual <- either throwIO pure $
-      wantedToActual bconfig.smWanted.compiler
+      wantedToActual buildConfig.smWanted.compiler
     let smActual = SMActual
           { compiler = actual
-          , project = bconfig.smWanted.project
-          , deps =  bconfig.smWanted.deps
+          , project = buildConfig.smWanted.project
+          , deps =  buildConfig.smWanted.deps
           , global = Map.mapWithKey toDump globals
           }
         toDump :: PackageName -> Version -> DumpPackage
@@ -143,9 +141,9 @@ withDotConfig opts inner =
     logDebug "Loading source map"
     sourceMap <- loadSourceMap targets boptsCLI smActual
     let dc = DotConfig
-                { dcBuildConfig = bconfig
-                , dcSourceMap = sourceMap
-                , dcGlobalDump = toList smActual.global
+                { buildConfig
+                , sourceMap
+                , globalDump = toList smActual.global
                 }
     logDebug "DotConfig fully loaded"
     runRIO dc inner
@@ -156,9 +154,9 @@ withDotConfig opts inner =
     installMap <- toInstallMap sourceMap
     (_, globalDump, _, _) <- getInstalled installMap
     let dc = DotConfig
-          { dcBuildConfig = envConfig.buildConfig
-          , dcSourceMap = sourceMap
-          , dcGlobalDump = globalDump
+          { buildConfig = envConfig.buildConfig
+          , sourceMap
+          , globalDump
           }
     runRIO dc inner
 
@@ -186,7 +184,7 @@ createDependencyGraph dotOpts = do
   locals <- for (toList sourceMap.project) loadLocalPackage
   let graph =
         Map.fromList $ projectPackageDependencies dotOpts (filter (.wanted) locals)
-  globalDump <- view $ to (.dcGlobalDump)
+  globalDump <- view $ to (.globalDump)
   -- TODO: Can there be multiple entries for wired-in-packages? If so,
   -- this will choose one arbitrarily..
   let globalDumpMap = Map.fromList $
@@ -355,48 +353,3 @@ pruneUnreachable dontPrune = fixpoint prune
 
 localPackageToPackage :: LocalPackage -> Package
 localPackageToPackage lp = fromMaybe lp.package lp.testBench
-
-data DotConfig = DotConfig
-  { dcBuildConfig :: !BuildConfig
-  , dcSourceMap :: !SourceMap
-  , dcGlobalDump :: ![DumpPackage]
-  }
-
-instance HasLogFunc DotConfig where
-  logFuncL = runnerL . logFuncL
-
-instance HasPantryConfig DotConfig where
-  pantryConfigL = configL . pantryConfigL
-
-instance HasTerm DotConfig where
-  useColorL = runnerL . useColorL
-  termWidthL = runnerL . termWidthL
-
-instance HasStylesUpdate DotConfig where
-  stylesUpdateL = runnerL . stylesUpdateL
-
-instance HasGHCVariant DotConfig where
-  ghcVariantL = configL . ghcVariantL
-  {-# INLINE ghcVariantL #-}
-
-instance HasPlatform DotConfig where
-  platformL = configL . platformL
-  {-# INLINE platformL #-}
-  platformVariantL = configL . platformVariantL
-  {-# INLINE platformVariantL #-}
-
-instance HasRunner DotConfig where
-  runnerL = configL . runnerL
-
-instance HasProcessContext DotConfig where
-  processContextL = runnerL . processContextL
-
-instance HasConfig DotConfig where
-  configL = buildConfigL . lens (.config) (\x y -> x { config = y })
-  {-# INLINE configL #-}
-
-instance HasBuildConfig DotConfig where
-  buildConfigL = lens (.dcBuildConfig) (\x y -> x { dcBuildConfig = y })
-
-instance HasSourceMap DotConfig where
-  sourceMapL = lens (.dcSourceMap) (\x y -> x { dcSourceMap = y })

src/Stack/Docker.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE NoFieldSelectors    #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
@@ -235,8 +236,8 @@ runContainerAndExit = do
       | otherwise -> throwM (NotPulledException image)
   projectRoot <- getProjectRoot
   sandboxDir <- projectDockerSandboxDir projectRoot
-  let ic = imageInfo.iiConfig
-      imageEnvVars = map (break (== '=')) ic.icEnv
+  let ic = imageInfo.config
+      imageEnvVars = map (break (== '=')) ic.env
       platformVariant = show $ hashRepoName image
       stackRoot = view stackRootL config
       sandboxHomeDir = sandboxDir </> homeDirName
@@ -323,8 +324,8 @@ runContainerAndExit = do
            -- Disable the deprecated entrypoint in FP Complete-generated images
         , [ "--entrypoint=/usr/bin/env"
           |  isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars)
-          && (  ic.icEntrypoint == ["/usr/local/sbin/docker-entrypoint"]
-             || ic.icEntrypoint == ["/root/entrypoint.sh"]
+          && (  ic.entrypoint == ["/usr/local/sbin/docker-entrypoint"]
+             || ic.entrypoint == ["/root/entrypoint.sh"]
              )
           ]
         , concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
@@ -627,10 +628,10 @@ oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
 
 -- | Parsed result of @docker inspect@.
 data Inspect = Inspect
-  { iiConfig      :: ImageConfig
-  , iiCreated     :: UTCTime
-  , iiId          :: Text
-  , iiVirtualSize :: Maybe Integer
+  { config      :: ImageConfig
+  , created     :: UTCTime
+  , iiId        :: Text
+  , virtualSize :: Maybe Integer
   }
   deriving Show
 
@@ -646,8 +647,8 @@ instance FromJSON Inspect where
 
 -- | Parsed @Config@ section of @docker inspect@ output.
 data ImageConfig = ImageConfig
-  { icEnv :: [String]
-  , icEntrypoint :: [String]
+  { env :: [String]
+  , entrypoint :: [String]
   }
   deriving Show
 

src/Stack/Eval.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors      #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
 
 -- | Types and functions related to Stack's @eval@ command.
 module Stack.Eval
@@ -16,8 +18,8 @@ import           Stack.Types.Runner ( Runner )
 
 -- Type representing command line options for the @stack eval@ command.
 data EvalOpts = EvalOpts
-  { evalArg :: !String
-  , evalExtra :: !ExecOptsExtra
+  { arg :: !String
+  , extra :: !ExecOptsExtra
   }
   deriving Show
 
@@ -27,7 +29,7 @@ evalCmd :: EvalOpts -> RIO Runner ()
 evalCmd eval = execCmd execOpts
  where
   execOpts = ExecOpts
-    { eoCmd = ExecGhc
-    , eoArgs = ["-e", eval.evalArg]
-    , eoExtra = eval.evalExtra
+    { cmd = ExecGhc
+    , args = ["-e", eval.arg]
+    , extra = eval.extra
     }