refactoring: put installed stuff into a dedicated types package

theobat · theobat · commit 3dd464d2692c · 2023-12-04T10:10:05.000Z
diff --git a/.stan.toml b/.stan.toml
@@ -54,25 +54,25 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-1128:21"
+  id = "OBS-STAN-0203-fki0nd-1129:21"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs
 #
-#  1127 ┃
-#  1128 ┃   newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
-#  1129 ┃                     ^^^^^^^
+#  1128 ┃
+#  1129 ┃   newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
+#  1130 ┃                     ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-2672:3"
+  id = "OBS-STAN-0203-fki0nd-2673:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs
 #
-#  2671 ┃
-#  2672 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
-#  2673 ┃   ^^^^^^^
+#  2672 ┃
+#  2673 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
+#  2674 ┃   ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs
@@ -71,9 +71,9 @@ import           Stack.Types.EnvConfig
                    , platformGhcRelDir
                    )
 import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
-import           Stack.Types.NamedComponent ( NamedComponent (..) )
-import           Stack.Types.Package
+import           Stack.Types.Installed
                    (InstalledLibraryInfo (..), installedGhcPkgId )
+import           Stack.Types.NamedComponent ( NamedComponent (..) )
 import           Stack.Types.SourceMap ( smRelDir )
 import           System.PosixCompat.Files
                    ( modificationTime, getFileStatus, setFileTimes )
diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -66,12 +66,14 @@ import           Stack.Types.EnvSettings
                    ( EnvSettings (..), minimalEnvSettings )
 import           Stack.Types.GhcPkgId ( GhcPkgId )
 import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
+import           Stack.Types.Installed
+                   ( InstallLocation (..), Installed (..), InstalledMap
+                   , installedVersion )
 import           Stack.Types.IsMutable ( IsMutable (..) )
 import           Stack.Types.NamedComponent ( exeComponents, renderComponent )
 import           Stack.Types.Package
-                   ( ExeName (..), InstallLocation (..), Installed (..)
-                   , InstalledMap, LocalPackage (..), Package (..)
-                   , PackageSource (..), installedMapGhcPkgId, installedVersion
+                   ( ExeName (..), LocalPackage (..), Package (..)
+                   , PackageSource (..), installedMapGhcPkgId
                    , packageIdentifier, psVersion, runMemoizedWith
                    )
 import           Stack.Types.ProjectConfig ( isPCGlobalProject )
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -178,16 +178,17 @@ import           Stack.Types.EnvConfig
 import           Stack.Types.EnvSettings ( EnvSettings (..) )
 import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString, unGhcPkgId )
 import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
+import           Stack.Types.Installed
+                   ( InstallLocation (..), Installed (..), InstalledMap
+                   , InstalledLibraryInfo (..), installedPackageIdentifier )
 import           Stack.Types.IsMutable ( IsMutable (..) )
 import           Stack.Types.NamedComponent
                    ( NamedComponent, benchComponents, exeComponents, isCBench
                    , isCTest, renderComponent, testComponents
                    )
 import           Stack.Types.Package
-                   ( InstallLocation (..), Installed (..)
-                   , InstalledLibraryInfo (..), InstalledMap, LocalPackage (..)
-                   , Package (..), installedMapGhcPkgId
-                   , installedPackageIdentifier, packageIdentifier
+                   ( LocalPackage (..), Package (..)
+                   , installedMapGhcPkgId, packageIdentifier
                    , runMemoizedWith, simpleInstalledLib
                    , toCabalMungedPackageName
                    )
diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs
@@ -29,12 +29,10 @@ import           Stack.Types.EnvConfig
                     , packageDatabaseLocal
                     )
 import           Stack.Types.GhcPkgId ( GhcPkgId )
-import           Stack.Types.Package
-                   ( InstallLocation (..), InstallMap, Installed (..)
-                   , InstalledLibraryInfo (..), InstalledMap
-                   , InstalledPackageLocation (..), PackageDatabase (..)
-                   , PackageDbVariety (..), toPackageDbVariety
-                   )
+import           Stack.Types.Installed
+                   ( InstallLocation (..), Installed (..), InstalledLibraryInfo (..)
+                   , InstallMap, InstalledMap, InstalledPackageLocation (..)
+                   , PackageDatabase (..), PackageDbVariety (..), toPackageDbVariety )
 import           Stack.Types.SourceMap
                    ( DepPackage (..), ProjectPackage (..), SourceMap (..) )
 
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -68,12 +68,13 @@ import           Stack.Types.EnvConfig
                    , shaPathForBytes
                    )
 import           Stack.Types.EnvSettings ( defaultEnvSettings )
+import           Stack.Types.Installed ( InstallMap, InstalledMap)
 import           Stack.Types.NamedComponent
                    ( NamedComponent (..), isCLib, renderPkgComponent )
 import           Stack.Types.Package
-                   ( BuildInfoOpts (..), InstallMap, InstalledMap
-                   , LocalPackage (..), Package (..), PackageConfig (..)
-                   , dotCabalCFilePath, dotCabalGetPath, dotCabalMainPath
+                   ( BuildInfoOpts (..), LocalPackage (..), Package (..)
+                   , PackageConfig (..), dotCabalCFilePath, dotCabalGetPath
+                   , dotCabalMainPath
                    )
 import           Stack.Types.PackageFile ( PackageComponentFile (..) )
 import           Stack.Types.Platform ( HasPlatform (..) )
diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs
@@ -93,14 +93,16 @@ import           Stack.Types.Dependency
                    , libraryDepFromVersionRange
                    )
 import           Stack.Types.EnvConfig ( HasEnvConfig )
+
+import           Stack.Types.Installed
+                   ( Installed (..), InstallMap, InstalledMap
+                   , installedToPackageIdOpt )
 import           Stack.Types.NamedComponent
                    ( NamedComponent (..), subLibComponents )
 import           Stack.Types.Package
-                   ( BioInput(..), BuildInfoOpts (..), InstallMap
-                   , Installed (..), InstalledMap, Package (..)
+                   ( BioInput(..), BuildInfoOpts (..), Package (..)
                    , PackageConfig (..), PackageException (..)
-                   , dotCabalCFilePath, installedToPackageIdOpt
-                   , packageIdentifier
+                   , dotCabalCFilePath, packageIdentifier
                    )
 import           Stack.Types.PackageFile
                    ( DotCabalPath, PackageComponentFile (..) )
@@ -293,7 +295,7 @@ generateBuildInfoOpts BioInput {..} =
   deps =
     concat
       [ case M.lookup name biInstalledMap of
-          Just (_, Stack.Types.Package.Library _ident installedInfo) ->
+          Just (_, Stack.Types.Installed.Library _ident installedInfo) ->
             installedToPackageIdOpt installedInfo
           _ -> ["-package=" <> packageNameString name <>
             maybe "" -- This empty case applies to e.g. base.
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
@@ -69,10 +69,13 @@ import           Stack.Types.Config ( Config (..), HasConfig (..) )
 import           Stack.Types.EnvConfig
                    ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
 import           Stack.Types.GhcPkgId ( GhcPkgId )
+import           Stack.Types.Installed
+                   ( InstallMap, Installed (..), InstalledMap
+                   , InstalledLibraryInfo (..), installedVersion
+                   )
 import           Stack.Types.Package
-                   ( InstallMap, Installed (..), InstalledLibraryInfo (..)
-                   , InstalledMap, LocalPackage (..), Package (..)
-                   , PackageConfig (..), installedVersion, packageIdentifier
+                   ( LocalPackage (..), Package (..)
+                   , PackageConfig (..), packageIdentifier
                    )
 import           Stack.Types.Platform ( HasPlatform (..) )
 import           Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs
@@ -36,10 +36,12 @@ import           Stack.Types.EnvConfig
                    ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) )
 import           Stack.Types.GhcPkgId ( GhcPkgId )
 import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
+import           Stack.Types.Installed
+                   ( InstallLocation, Installed (..)
+                   , installedVersion)
 import           Stack.Types.Package
-                   ( ExeName (..), InstallLocation, Installed (..)
-                   , LocalPackage (..), Package (..), PackageSource (..)
-                   , installedVersion
+                   ( ExeName (..), LocalPackage (..), Package (..)
+                   , PackageSource (..)
                    )
 import           Stack.Types.ParentMap ( ParentMap )
 import           Stack.Types.Platform ( HasPlatform (..) )
diff --git a/src/Stack/Types/Installed.hs b/src/Stack/Types/Installed.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | This module contains all the types related to the idea of installing a package
+-- in the pkg-db or an executable on the file system.
+module Stack.Types.Installed
+  ( InstallLocation (..)
+  , InstalledPackageLocation (..)
+  , PackageDatabase (..)
+  , PackageDbVariety (..)
+  , InstallMap
+  , Installed (..)
+  , InstalledMap
+  , InstalledLibraryInfo (..)
+  , toPackageDbVariety
+  , installedLibraryInfoFromGhcPkgId
+  , simpleInstalledLib
+  , installedToPackageIdOpt
+  , installedPackageIdentifier
+  , installedGhcPkgId
+  , installedVersion
+  ) where
+
+import qualified Distribution.SPDX.License as SPDX
+import           Distribution.License (License)
+import           Stack.Prelude
+import           Stack.Types.ComponentUtils (StackUnqualCompName)
+import           Stack.Types.GhcPkgId (GhcPkgId, ghcPkgIdString)
+import qualified Data.Map as M
+
+-- | Type representing user package databases that packages can be installed
+-- into.
+data InstallLocation
+  = Snap
+    -- ^ The write-only package database, formerly known as the snapshot
+    -- database.
+  | Local
+    -- ^ The mutable package database, formerly known as the local database.
+  deriving (Eq, Show)
+
+instance Semigroup InstallLocation where
+  Local <> _ = Local
+  _ <> Local = Local
+  Snap <> Snap = Snap
+
+instance Monoid InstallLocation where
+  mempty = Snap
+  mappend = (<>)
+
+-- | Type representing user (non-global) package databases that can provide
+-- installed packages.
+data InstalledPackageLocation
+  = InstalledTo InstallLocation
+    -- ^ A package database that a package can be installed into.
+  | ExtraPkgDb
+    -- ^ An \'extra\' package database, specified by @extra-package-dbs@.
+  deriving (Eq, Show)
+
+-- | Type representing package databases that can provide installed packages.
+data PackageDatabase
+  = GlobalPkgDb
+    -- ^ GHC's global package database.
+  | UserPkgDb InstalledPackageLocation (Path Abs Dir)
+    -- ^ A user package database.
+  deriving (Eq, Show)
+
+-- | A function to yield the variety of package database for a given
+-- package database that can provide installed packages.
+toPackageDbVariety :: PackageDatabase -> PackageDbVariety
+toPackageDbVariety GlobalPkgDb = GlobalDb
+toPackageDbVariety (UserPkgDb ExtraPkgDb _) = ExtraDb
+toPackageDbVariety (UserPkgDb (InstalledTo Snap) _) = WriteOnlyDb
+toPackageDbVariety (UserPkgDb (InstalledTo Local) _) = MutableDb
+
+-- | Type representing varieties of package databases that can provide
+-- installed packages.
+data PackageDbVariety
+  = GlobalDb
+    -- ^ GHC's global package database.
+  | ExtraDb
+    -- ^ An \'extra\' package database, specified by @extra-package-dbs@.
+  | WriteOnlyDb
+    -- ^ The write-only package database, for immutable packages.
+  | MutableDb
+    -- ^ The mutable package database.
+  deriving (Eq, Show)
+
+-- | Type synonym representing dictionaries of package names for a project's
+-- packages and dependencies, and pairs of their relevant database (write-only
+-- or mutable) and package versions.
+type InstallMap = Map PackageName (InstallLocation, Version)
+
+-- | Type synonym representing dictionaries of package names, and a pair of in
+-- which package database the package is installed (write-only or mutable) and
+-- information about what is installed.
+type InstalledMap = Map PackageName (InstallLocation, Installed)
+
+data InstalledLibraryInfo = InstalledLibraryInfo
+  { iliId :: GhcPkgId
+  , iliLicense :: Maybe (Either SPDX.License License)
+  , iliSublib :: Map StackUnqualCompName GhcPkgId
+  }
+  deriving (Eq, Show)
+
+-- | Type representing information about what is installed.
+data Installed
+  = Library PackageIdentifier InstalledLibraryInfo
+    -- ^ A library, including its installed package id and, optionally, its
+    -- license.
+  | Executable PackageIdentifier
+    -- ^ An executable.
+  deriving (Eq, Show)
+
+installedLibraryInfoFromGhcPkgId :: GhcPkgId -> InstalledLibraryInfo
+installedLibraryInfoFromGhcPkgId ghcPkgId =
+  InstalledLibraryInfo ghcPkgId Nothing mempty
+
+simpleInstalledLib ::
+     PackageIdentifier
+  -> GhcPkgId
+  -> Map StackUnqualCompName GhcPkgId
+  -> Installed
+simpleInstalledLib pkgIdentifier ghcPkgId =
+  Library pkgIdentifier . InstalledLibraryInfo ghcPkgId Nothing
+
+installedToPackageIdOpt :: InstalledLibraryInfo -> [String]
+installedToPackageIdOpt libInfo =
+  M.foldr' (iterator (++)) (pure $ toStr (iliId libInfo)) (iliSublib libInfo)
+ where
+  toStr ghcPkgId = "-package-id=" <> ghcPkgIdString ghcPkgId
+  iterator op ghcPkgId acc = pure (toStr ghcPkgId) `op` acc
+
+installedPackageIdentifier :: Installed -> PackageIdentifier
+installedPackageIdentifier (Library pid _) = pid
+installedPackageIdentifier (Executable pid) = pid
+
+installedGhcPkgId :: Installed -> Maybe GhcPkgId
+installedGhcPkgId (Library _ libInfo) = Just $ iliId libInfo
+installedGhcPkgId (Executable _) = Nothing
+
+-- | Get the installed Version.
+installedVersion :: Installed -> Version
+installedVersion i =
+  let PackageIdentifier _ version = installedPackageIdentifier i
+  in  version
diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs
diff --git a/stack.cabal b/stack.cabal
