Build with NoFieldSelectors

feat: remove getField where RecordDot is simpler

.hlint-test.yaml

@@ -9,6 +9,7 @@
   - name:
     - NoImplicitPrelude
     - CPP
+    - NoFieldSelectors
     - OverloadedLists
       # Provided from GHC 9.2.1 (base-4.16.0.0):
     - OverloadedRecordDot

.hlint.yaml

@@ -70,6 +70,7 @@
     - GeneralizedNewtypeDeriving
     - LambdaCase
     - MultiWayIf
+    - NoFieldSelectors
     - OverloadedLists
       # Provided from GHC 9.2.1 (base-4.16.0.0):
     - OverloadedRecordDot

.stan.toml

@@ -25,7 +25,7 @@
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-522:30"
+  id = "OBS-STAN-0102-luLR/n-523:30"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #
@@ -36,7 +36,7 @@
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-522:65"
+  id = "OBS-STAN-0102-luLR/n-523:65"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #
@@ -54,47 +54,47 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-1134:21"
+  id = "OBS-STAN-0203-fki0nd-1132:21"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs
 #
-#  1133 ┃
-#  1134 ┃   newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
-#  1135 ┃                     ^^^^^^^
+#  1131 ┃
+#  1132 ┃   newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
+#  1133 ┃                     ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-2680:3"
+  id = "OBS-STAN-0203-fki0nd-2678:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs
 #
-#  2679 ┃
-#  2680 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
-#  2681 ┃   ^^^^^^^
+#  2677 ┃
+#  2678 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
+#  2679 ┃   ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-hTeu0Y-380:17"
+  id = "OBS-STAN-0203-hTeu0Y-381:17"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Init.hs
 #
-#  379 ┃
-#  380 ┃   commentHelp = BC.pack .  intercalate "\n" . map commentLine
-#  381 ┃                 ^^^^^^^
+#  380 ┃
+#  381 ┃   commentHelp = BC.pack .  intercalate "\n" . map commentLine
+#  382 ┃                 ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-hTeu0Y-397:26"
+  id = "OBS-STAN-0203-hTeu0Y-398:26"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Init.hs
 #
-#  396 ┃
-#  397 ┃         <> B.byteString (BC.pack $ concat
-#  398 ┃                          ^^^^^^^
+#  397 ┃
+#  398 ┃         <> B.byteString (BC.pack $ concat
+#  399 ┃                          ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
@@ -170,6 +170,28 @@
 #  484 ┃     embedFile path)
 #  485 ┃
 
+# Anti-pattern: unsafe functions
+[[ignore]]
+  id = "OBS-STAN-0212-H4Wfj/-151:17"
+# ✦ Description:   Usage of unsafe functions breaks referential transparency
+# ✦ Category:      #Unsafe #AntiPattern
+# ✦ File:          src\Stack\Types\BuildOpts.hs
+#
+#  150 ┃
+#  151 ┃   buildMonoid = undefined :: BuildOptsMonoid
+#  152 ┃                 ^^^^^^^^^
+
+# Anti-pattern: unsafe functions
+[[ignore]]
+  id = "OBS-STAN-0212-H4Wfj/-480:14"
+# ✦ Description:   Usage of unsafe functions breaks referential transparency
+# ✦ Category:      #Unsafe #AntiPattern
+# ✦ File:          src\Stack\Types\BuildOpts.hs
+#
+#   479 ┃
+#   480 ┃   toMonoid = undefined :: TestOptsMonoid
+#   481 ┃              ^^^^^^^^^
+
 # Anti-pattern: Pattern matching on '_'
 # Pattern matching on '_' for sum types can create maintainability issues
 # Stack uses pattern matching on '_' in many places.

src/Control/Concurrent/Execute.hs

@@ -98,16 +98,16 @@ runActions threads keepGoing actions withProgress = do
     <*> newTVarIO Set.empty -- esInAction
     <*> newTVarIO 0 -- esCompleted
     <*> pure keepGoing -- esKeepGoing
-  _ <- async $ withProgress (esCompleted es) (esInAction es)
+  _ <- async $ withProgress es.esCompleted es.esInAction
   if threads <= 1
     then runActions' es
     else replicateConcurrently_ threads $ runActions' es
-  readTVarIO $ esExceptions es
+  readTVarIO es.esExceptions
 
 -- | Sort actions such that those that can't be run concurrently are at
 -- the end.
 sortActions :: [Action] -> [Action]
-sortActions = sortBy (compareConcurrency `on` actionConcurrency)
+sortActions = sortBy (compareConcurrency `on` (.actionConcurrency))
  where
   -- NOTE: Could derive Ord. However, I like to make this explicit so
   -- that changes to the datatype must consider how it's affecting
@@ -139,7 +139,7 @@ runActions' es = loop
   processActions :: [Action] -> STM (IO ())
   processActions actions = do
     inAction <- readTVar es.esInAction
-    case break (Set.null . actionDeps) actions of
+    case break (Set.null . (.actionDeps)) actions of
       (_, []) -> do
         check (Set.null inAction)
         unless es.esKeepGoing $
@@ -149,11 +149,11 @@ runActions' es = loop
 
   processAction :: Set ActionId -> [Action] -> Action -> STM (IO ())
   processAction inAction otherActions action = do
-    let concurrency = actionConcurrency action
+    let concurrency = action.actionConcurrency
     unless (concurrency == ConcurrencyAllowed) $
       check (Set.null inAction)
-    let action' = actionId action
-        otherActions' = Set.fromList $ map actionId otherActions
+    let action' = action.actionId
+        otherActions' = Set.fromList $ map (.actionId) otherActions
         remaining = Set.union otherActions' inAction
         actionContext = ActionContext
           { acRemaining = remaining
@@ -164,7 +164,7 @@ runActions' es = loop
     modifyTVar es.esInAction (Set.insert action')
     pure $ do
       mask $ \restore -> do
-        eres <- try $ restore $ actionDo action actionContext
+        eres <- try $ restore $ action.actionDo actionContext
         atomically $ do
           modifyTVar es.esInAction (Set.delete action')
           modifyTVar es.esCompleted (+1)
@@ -176,13 +176,13 @@ runActions' es = loop
   -- | Filter a list of actions to include only those that depend on the given
   -- action.
   downstreamActions :: ActionId -> [Action] -> [Action]
-  downstreamActions aid = filter (\a -> aid `Set.member` actionDeps a)
+  downstreamActions aid = filter (\a -> aid `Set.member` a.actionDeps)
 
   -- | Given two actions (the first specified by its id) yield an action
   -- equivalent to the second but excluding any dependency on the first action.
   dropDep :: ActionId -> Action -> Action
   dropDep action' action =
-    action { actionDeps = Set.delete action' $ actionDeps action }
+    action { actionDeps = Set.delete action' action.actionDeps }
 
   -- | @IO ()@ lifted into 'STM'.
   doNothing :: STM (IO ())

src/GHC/Utils/GhcPkg/Main/Compat.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE KindSignatures        #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TupleSections         #-}
@@ -282,19 +283,19 @@ getPkgDatabases globalDb pkgarg pkgDb = do
 
   (db_stack, db_to_operate_on) <- getDatabases pkgDb final_stack
 
-  let flag_db_stack = [ db | db <- db_stack, location db == Abs pkgDb ]
+  let flag_db_stack = [ db | db <- db_stack, db.location == Abs pkgDb ]
 
   prettyDebugL
     $ flow "Db stack:"
-    : map (pretty . location) db_stack
+    : map (pretty . (.location)) db_stack
   F.forM_ db_to_operate_on $ \db ->
     prettyDebugL
       [ "Modifying:"
-      , pretty $ location db
+      , pretty db.location
       ]
   prettyDebugL
     $ flow "Flag db stack:"
-    : map (pretty . location) flag_db_stack
+    : map (pretty . (.location)) flag_db_stack
 
   pure (db_stack, db_to_operate_on, flag_db_stack)
  where
@@ -310,7 +311,7 @@ getPkgDatabases globalDb pkgarg pkgDb = do
               then (, Nothing) <$> readDatabase db_path
               else do
                 let hasPkg :: PackageDB mode -> Bool
-                    hasPkg = not . null . findPackage pkgarg . packages
+                    hasPkg = not . null . findPackage pkgarg . (.packages)
 
                     openRo (e::IOException) = do
                       db <- readDatabase db_path
@@ -332,7 +333,7 @@ getPkgDatabases globalDb pkgarg pkgDb = do
                       -- If the database is not for modification after all,
                       -- drop the write lock as we are already finished with
                       -- the database.
-                      case packageDbLock db of
+                      case db.packageDbLock of
                         GhcPkg.DbOpenReadWrite lock ->
                           liftIO $ GhcPkg.unlockPackageDb lock
                       pure (ro_db, Nothing)
@@ -468,14 +469,14 @@ adjustOldFileStylePackageDB :: PackageDB mode -> RIO env (PackageDB mode)
 adjustOldFileStylePackageDB db = do
   -- assumes we have not yet established if it's an old style or not
   mcontent <- liftIO $
-    fmap Just (readFile (prjSomeBase toFilePath (location db))) `catchIO` \_ -> pure Nothing
+    fmap Just (readFile (prjSomeBase toFilePath db.location)) `catchIO` \_ -> pure Nothing
   case fmap (take 2) mcontent of
     -- it is an old style and empty db, so look for a dir kind in location.d/
     Just "[]" -> do
-      adjustedDatabasePath <- adjustOldDatabasePath $ location db
+      adjustedDatabasePath <- adjustOldDatabasePath db.location
       pure db { location = adjustedDatabasePath }
     -- it is old style but not empty, we have to bail
-    Just _ -> prettyThrowIO $ SingleFileDBUnsupported (location db)
+    Just _ -> prettyThrowIO $ SingleFileDBUnsupported db.location
     -- probably not old style, carry on as normal
     Nothing -> pure db
 
@@ -513,7 +514,7 @@ changeNewDB ::
   -> RIO env ()
 changeNewDB cmds new_db = do
   new_db' <- adjustOldFileStylePackageDB new_db
-  prjSomeBase (createDirIfMissing True) (location new_db')
+  prjSomeBase (createDirIfMissing True) new_db'.location
   changeDBDir' cmds new_db'
 
 changeDBDir' ::
@@ -523,7 +524,7 @@ changeDBDir' ::
   -> RIO env ()
 changeDBDir' cmds db = do
   mapM_ do_cmd cmds
-  case packageDbLock db of
+  case db.packageDbLock of
     GhcPkg.DbOpenReadWrite lock -> liftIO $ GhcPkg.unlockPackageDb lock
  where
   do_cmd (RemovePackage p) = do
@@ -532,7 +533,7 @@ changeDBDir' cmds db = do
       (prettyThrowIO $ CannotParseRelFileBug relFileConfName)
       pure
       (parseRelFile relFileConfName)
-    let file = mapSomeBase (P.</> relFileConf) (location db)
+    let file = mapSomeBase (P.</> relFileConf) db.location
     prettyDebugL
       [ "Removing"
       , pretty file
@@ -566,7 +567,7 @@ unregisterPackages globalDb pkgargs pkgDb = do
     getPkgDatabases globalDb pkgarg pkgDb >>= \case
       (_, GhcPkg.DbOpenReadWrite (db :: PackageDB GhcPkg.DbReadWrite), _) -> do
         pks <- do
-          let pkgs = packages db
+          let pkgs = db.packages
               ps = findPackage pkgarg pkgs
           -- This shouldn't happen if getPkgsByPkgDBs picks the DB correctly.
           when (null ps) $ cannotFindPackage pkgarg $ Just db
@@ -577,7 +578,7 @@ unregisterPackages globalDb pkgargs pkgDb = do
   -- consider.
   getPkgsByPkgDBs pkgsByPkgDBs ( pkgsByPkgDB : pkgsByPkgDBs') pkgarg = do
     let (db, pks') = pkgsByPkgDB
-        pkgs = packages db
+        pkgs = db.packages
         ps = findPackage pkgarg pkgs
         pks = map installedUnitId ps
         pkgByPkgDB' = (db, pks <> pks')
@@ -595,7 +596,7 @@ unregisterPackages globalDb pkgargs pkgDb = do
 
   unregisterPackages' :: (PackageDB GhcPkg.DbReadWrite, [UnitId]) -> RIO env ()
   unregisterPackages' (db, pks) = do
-    let pkgs = packages db
+    let pkgs = db.packages
         cmds = [ RemovePackage pkg
                | pkg <- pkgs, installedUnitId pkg `elem` pks
                ]
@@ -618,7 +619,7 @@ findPackage pkgarg = filter (pkgarg `matchesPkg`)
 
 cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> RIO env a
 cannotFindPackage pkgarg mdb =
-  prettyThrowIO $ CannotFindPackage pkgarg (location <$> mdb)
+  prettyThrowIO $ CannotFindPackage pkgarg ((.location) <$> mdb)
 
 matches :: GlobPackageIdentifier -> MungedPackageId -> Bool
 GlobPackageIdentifier pn `matches` pid' = pn == mungedName pid'

src/Stack.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE GADTs               #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
 -- | Main Stack tool entry point.
@@ -77,9 +78,9 @@ main = do
       throwIO exitCode
     Right (globalMonoid, run) -> do
       global <- globalOptsFromMonoid isTerminal globalMonoid
-      when (globalLogLevel global == LevelDebug) $
+      when (global.globalLogLevel == LevelDebug) $
         hPutStrLn stderr versionString'
-      case globalReExecVersion global of
+      case global.globalReExecVersion of
         Just expectVersion -> do
           expectVersion' <- parseVersionThrowing expectVersion
           unless (checkVersion MatchMinor expectVersion' stackVersion) $