Installed.hs

{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}

{-|
Module      : Stack.Types.Installed
License     : BSD-3-Clause

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
  , installedVersion
  , foldOnGhcPkgId'
  ) 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
  { ghcPkgId :: GhcPkgId
  , license :: Maybe (Either SPDX.License License)
  , subLib :: 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 libInfo.ghcPkgId) libInfo.subLib
 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

-- | A strict fold over the 'GhcPkgId' of the given installed package. This will
-- iterate on both sub and main libraries, if any.
foldOnGhcPkgId' ::
     (Maybe StackUnqualCompName -> GhcPkgId -> resT -> resT)
  -> Installed
  -> resT
  -> resT
foldOnGhcPkgId' _ Executable{} res = res
foldOnGhcPkgId' fn (Library _ libInfo) res =
  M.foldrWithKey' (fn . Just) (base res) libInfo.subLib
 where
  base = fn Nothing libInfo.ghcPkgId

-- | Get the installed Version.
installedVersion :: Installed -> Version
installedVersion i =
  let PackageIdentifier _ version = installedPackageIdentifier i
  in  version