Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

refactoring: put installed stuff into a dedicated types package #6357

Merged
merged 3 commits into from
Dec 4, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
16 changes: 8 additions & 8 deletions .stan.toml
Original file line number Diff line number Diff line change
Expand Up @@ -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]]
Expand Down
1 change: 1 addition & 0 deletions package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -306,6 +306,7 @@ library:
- Stack.Types.GhcPkgId
- Stack.Types.GlobalOpts
- Stack.Types.GlobalOptsMonoid
- Stack.Types.Installed
- Stack.Types.IsMutable
- Stack.Types.LockFileBehavior
- Stack.Types.NamedComponent
Expand Down
4 changes: 2 additions & 2 deletions src/Stack/Build/Cache.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 )
Expand Down
9 changes: 6 additions & 3 deletions src/Stack/Build/ConstructPlan.hs
Original file line number Diff line number Diff line change
Expand Up @@ -66,12 +66,15 @@ 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 )
Expand Down
11 changes: 6 additions & 5 deletions src/Stack/Build/Execute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -178,17 +178,18 @@ 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
, runMemoizedWith, simpleInstalledLib
( LocalPackage (..), Package (..), installedMapGhcPkgId
, packageIdentifier, runMemoizedWith, simpleInstalledLib
, toCabalMungedPackageName
)
import Stack.Types.PackageFile ( PackageWarning (..) )
Expand Down
2 changes: 1 addition & 1 deletion src/Stack/Build/Installed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ import Stack.Types.EnvConfig
, packageDatabaseLocal
)
import Stack.Types.GhcPkgId ( GhcPkgId )
import Stack.Types.Package
import Stack.Types.Installed
( InstallLocation (..), InstallMap, Installed (..)
, InstalledLibraryInfo (..), InstalledMap
, InstalledPackageLocation (..), PackageDatabase (..)
Expand Down
7 changes: 4 additions & 3 deletions src/Stack/Ghci.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..) )
Expand Down
12 changes: 7 additions & 5 deletions src/Stack/Package.hs
Original file line number Diff line number Diff line change
Expand Up @@ -93,14 +93,16 @@ import Stack.Types.Dependency
, libraryDepFromVersionRange
)
import Stack.Types.EnvConfig ( HasEnvConfig )
import Stack.Types.Installed
( InstallMap, Installed (..), 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 (..) )
Expand Down Expand Up @@ -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.
Expand Down
9 changes: 6 additions & 3 deletions src/Stack/SDist.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..) )
Expand Down
7 changes: 4 additions & 3 deletions src/Stack/Types/Build/ConstructPlan.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,10 +36,11 @@ 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 (..) )
Expand Down
144 changes: 144 additions & 0 deletions src/Stack/Types/Installed.hs
Original file line number Diff line number Diff line change
@@ -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 Data.Map as M
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 )

-- | 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
Loading
Loading