Merge pull request #6459 from commercialhaskell/newtype-prefix

Remove prefixes from newtype fields

Author: mpilgrem

src/Stack/Ghci/Script.hs

@@ -19,7 +19,7 @@ import           Distribution.ModuleName ( ModuleName, components )
 import           Stack.Prelude
 import           System.IO ( hSetBinaryMode )
 
-newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] }
+newtype GhciScript = GhciScript { ghciScript :: [GhciCommand] }
 
 instance Semigroup GhciScript where
   GhciScript xs <> GhciScript ys = GhciScript (ys <> xs)
@@ -45,7 +45,7 @@ scriptToLazyByteString = toLazyByteString . scriptToBuilder
 scriptToBuilder :: GhciScript -> Builder
 scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script
  where
-  script = reverse backwardScript.unGhciScript
+  script = reverse backwardScript.ghciScript
 
 scriptToFile :: Path Abs File -> GhciScript -> IO ()
 scriptToFile path script =

src/Stack/Lock.hs

@@ -76,7 +76,7 @@ instance ( FromJSON (WithJSONWarnings (Unresolved a))
 -- serialization should not produce locations with multiple subdirs
 -- so we should be OK using just a head element
 newtype SingleRPLI
-  = SingleRPLI { unSingleRPLI :: RawPackageLocationImmutable}
+  = SingleRPLI { singleRPLI :: RawPackageLocationImmutable}
 
 instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where
   parseJSON v =
@@ -103,7 +103,7 @@ instance FromJSON (WithJSONWarnings (Unresolved Locked)) where
     snapshots <- jsonSubWarningsT $ o ..: "snapshots"
     packages <- jsonSubWarningsT $ o ..: "packages"
     let unwrap :: LockedLocation SingleRPLI b -> LockedLocation RawPackageLocationImmutable b
-        unwrap ll = ll { original = ll.original.unSingleRPLI }
+        unwrap ll = ll { original = ll.original.singleRPLI }
     pure $ Locked <$> sequenceA snapshots <*> (map unwrap <$> sequenceA packages)
 
 loadYamlThrow ::

src/Stack/Ls.hs

@@ -73,7 +73,7 @@ instance Exception LsException where
 
 -- | Type representing command line options for the @stack ls@ command.
 newtype LsCmdOpts
-  = LsCmdOpts { lsView :: LsCmds }
+  = LsCmdOpts { lsCmds :: LsCmds }
 
 -- | Type representing subcommands for the @stack ls@ command.
 data LsCmds
@@ -143,7 +143,7 @@ data ListStylesOpts = ListStylesOpts
 
 -- | Type representing command line options for the @stack ls tools@ command.
 newtype ListToolsOpts
-  = ListToolsOpts { toptFilter  :: String }
+  = ListToolsOpts { filter  :: String }
 
 data Snapshot = Snapshot
   { snapId :: Text
@@ -236,7 +236,7 @@ handleLocal lsOpts = do
         | otherwise   = parent parentInstRoot
   snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir
   let snapData = L.sort snapData'
-  case lsOpts.lsView of
+  case lsOpts.lsCmds of
     LsSnapshot sopt ->
       case (sopt.ltsSnapView, sopt.nightlySnapView) of
         (True, False) ->
@@ -259,7 +259,7 @@ handleRemote lsOpts = do
   let req' = addRequestHeader hAccept "application/json" req
   result <- httpJSON req'
   let snapData = getResponseBody result
-  case lsOpts.lsView of
+  case lsOpts.lsCmds of
     LsSnapshot sopt ->
       case (sopt.ltsSnapView, sopt.nightlySnapView) of
         (True, False) ->
@@ -279,7 +279,7 @@ handleRemote lsOpts = do
 
 lsCmd :: LsCmdOpts -> RIO Runner ()
 lsCmd lsOpts =
-  case lsOpts.lsView of
+  case lsOpts.lsCmds of
     LsSnapshot sopt ->
       case sopt.viewType of
         Local -> handleLocal lsOpts
@@ -320,7 +320,7 @@ listToolsCmd :: ListToolsOpts -> RIO Config ()
 listToolsCmd opts = do
   localPrograms <- view $ configL . to (.localPrograms)
   installed <- sort <$> listInstalled localPrograms
-  let wanted = case opts.toptFilter of
+  let wanted = case opts.filter of
         [] -> installed
         "ghc-git" -> [t | t@(ToolGhcGit _ _) <- installed]
         pkgName -> filtered pkgName installed

src/Stack/Prelude.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE NoFieldSelectors    #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
@@ -272,7 +273,7 @@ promptBool txt = liftIO $ do
 
 -- | Like @First Bool@, but the default is @True@.
 newtype FirstTrue
-  = FirstTrue { getFirstTrue :: Maybe Bool }
+  = FirstTrue { firstTrue :: Maybe Bool }
   deriving (Eq, Ord, Show)
 
 instance Semigroup FirstTrue where
@@ -285,15 +286,15 @@ instance Monoid FirstTrue where
 
 -- | Get the 'Bool', defaulting to 'True'
 fromFirstTrue :: FirstTrue -> Bool
-fromFirstTrue = fromMaybe True . (.getFirstTrue)
+fromFirstTrue = fromMaybe True . (.firstTrue)
 
 -- | Helper for filling in default values
 defaultFirstTrue :: FirstTrue -> Bool
 defaultFirstTrue _ = True
 
 -- | Like @First Bool@, but the default is @False@.
 newtype FirstFalse
-  = FirstFalse { getFirstFalse :: Maybe Bool }
+  = FirstFalse { firstFalse :: Maybe Bool }
   deriving (Eq, Ord, Show)
 
 instance Semigroup FirstFalse where
@@ -306,7 +307,7 @@ instance Monoid FirstFalse where
 
 -- | Get the 'Bool', defaulting to 'False'
 fromFirstFalse :: FirstFalse -> Bool
-fromFirstFalse = fromMaybe False . (.getFirstFalse)
+fromFirstFalse = fromMaybe False . (.firstFalse)
 
 -- | Helper for filling in default values
 defaultFirstFalse :: FirstFalse -> Bool

src/Stack/Storage/Project.hs

@@ -98,7 +98,7 @@ withProjectStorage ::
   => ReaderT SqlBackend (RIO env) a
   -> RIO env a
 withProjectStorage inner = do
-  storage <- view (buildConfigL . to (.projectStorage.unProjectStorage))
+  storage <- view (buildConfigL . to (.projectStorage.projectStorage))
   withStorage_ storage inner
 
 -- | Key used to retrieve configuration or flag cache

src/Stack/Storage/User.hs

@@ -168,7 +168,7 @@ withUserStorage ::
   => ReaderT SqlBackend (RIO env) a
   -> RIO env a
 withUserStorage inner = do
-  storage <- view (configL . to (.userStorage.unUserStorage))
+  storage <- view (configL . to (.userStorage.userStorage))
   withStorage_ storage inner
 
 -- | Key used to retrieve the precompiled cache

src/Stack/Types/BuildOptsMonoid.hs

@@ -337,7 +337,7 @@ newtype CabalVerbosity
   deriving (Eq, Show)
 
 toFirstCabalVerbosity :: FirstFalse -> First CabalVerbosity
-toFirstCabalVerbosity vf = First $ vf.getFirstFalse <&> \p ->
+toFirstCabalVerbosity vf = First $ vf.firstFalse <&> \p ->
   if p then verboseLevel else normalLevel
  where
   verboseLevel = CabalVerbosity verbose
@@ -355,22 +355,22 @@ instance Parsec CabalVerbosity where
 
 buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)
 buildOptsMonoidHaddockL =
-  lens (.buildHaddocks.getFirstFalse)
+  lens (.buildHaddocks.firstFalse)
     (\buildMonoid t -> buildMonoid {buildHaddocks = FirstFalse t})
 
 buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)
 buildOptsMonoidTestsL =
-  lens (.tests.getFirstFalse)
+  lens (.tests.firstFalse)
     (\buildMonoid t -> buildMonoid {tests = FirstFalse t})
 
 buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)
 buildOptsMonoidBenchmarksL =
-  lens (.benchmarks.getFirstFalse)
+  lens (.benchmarks.firstFalse)
     (\buildMonoid t -> buildMonoid {benchmarks = FirstFalse t})
 
 buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)
 buildOptsMonoidInstallExesL =
-  lens (.installExes.getFirstFalse)
+  lens (.installExes.firstFalse)
     (\buildMonoid t -> buildMonoid {installExes = FirstFalse t})
 
 -- Type representing formats of Stack's progress bar when building.

src/Stack/Types/ConfigMonoid.hs

@@ -238,7 +238,7 @@ parseConfigMonoidObject rootDir obj = do
   skipGHCCheck <- FirstFalse <$> obj ..:? configMonoidSkipGHCCheckName
   skipMsys <- FirstFalse <$> obj ..:? configMonoidSkipMsysName
   requireStackVersion <-
-    IntersectingVersionRange . (.unVersionRangeJSON) <$>
+    IntersectingVersionRange . (.versionRangeJSON) <$>
       ( obj ..:? configMonoidRequireStackVersionName
           ..!= VersionRangeJSON anyVersion
       )

src/Stack/Types/Docker.hs

@@ -354,7 +354,7 @@ instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
     stackExe <- First <$> o ..:? dockerStackExeArgName
     setUser <- First <$> o ..:? dockerSetUserArgName
     requireDockerVersion <-
-      IntersectingVersionRange . (.unVersionRangeJSON) <$>
+      IntersectingVersionRange . (.versionRangeJSON) <$>
         ( o ..:? dockerRequireDockerVersionArgName
           ..!= VersionRangeJSON anyVersion
         )
@@ -444,7 +444,7 @@ data DockerMonoidRepoOrImage
 
 -- | Newtype for non-orphan FromJSON instance.
 newtype VersionRangeJSON =
-  VersionRangeJSON { unVersionRangeJSON :: VersionRange }
+  VersionRangeJSON { versionRangeJSON :: VersionRange }
 
 -- | Parse VersionRange.
 instance FromJSON VersionRangeJSON where

src/Stack/Types/Storage.hs

@@ -59,10 +59,10 @@ instance Exception StoragePrettyException
 
 -- | A bit of type safety to ensure we're talking to the right database.
 newtype UserStorage = UserStorage
-  { unUserStorage :: Storage
+  { userStorage :: Storage
   }
 
 -- | A bit of type safety to ensure we're talking to the right database.
 newtype ProjectStorage = ProjectStorage
-  { unProjectStorage :: Storage
+  { projectStorage :: Storage
   }