FieldGrammar.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Distribution.Types.InstalledPackageInfo.FieldGrammar
  ( ipiFieldGrammar
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Backpack
import Distribution.CabalSpecVersion
import Distribution.Compat.Lens (Lens', (&), (.~))
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
import Distribution.License
import Distribution.ModuleName
import Distribution.Package
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Types.LibraryName
import Distribution.Types.LibraryVisibility
import Distribution.Types.MungedPackageName
import Distribution.Types.UnqualComponentName
import Distribution.Version

import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.SPDX as SPDX
import qualified Text.PrettyPrint as Disp

import Distribution.Types.InstalledPackageInfo

import qualified Distribution.Types.InstalledPackageInfo.Lens as L
import qualified Distribution.Types.PackageId.Lens as L

-- Note: GHC goes nuts and inlines everything,
-- One can see e.g. in -ddump-simpl-stats:
--
-- 34886 KnownBranch
--  8197 wild1_ixF0
--
-- https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause.
--
-- The workaround is to prevent GHC optimising the code:
infixl 4 <@>
(<@>) :: Applicative f => f (a -> b) -> f a -> f b
f <@> x = f <*> x
{-# NOINLINE (<@>) #-}

ipiFieldGrammar
  :: ( FieldGrammar c g
     , Applicative (g InstalledPackageInfo)
     , Applicative (g Basic)
     , c (Identity AbiHash)
     , c (Identity LibraryVisibility)
     , c (Identity PackageName)
     , c (Identity UnitId)
     , c (Identity UnqualComponentName)
     , c (List FSep (Identity AbiDependency) AbiDependency)
     , c (List FSep (Identity UnitId) UnitId)
     , c (List FSep (MQuoted ModuleName) ModuleName)
     , c (List FSep FilePathNT String)
     , c (List FSep Token String)
     , c (MQuoted MungedPackageName)
     , c (MQuoted Version)
     , c CompatPackageKey
     , c ExposedModules
     , c InstWith
     , c SpecLicenseLenient
     )
  => g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar =
  mkInstalledPackageInfo
    -- Deprecated fields
    <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList
      --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b
      ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore"
    -- Very basic fields: name, version, package-name, lib-name and visibility
    <@> blurFieldGrammar basic basicFieldGrammar
    -- Basic fields
    <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "")
    <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
    <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
    <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
    <@> freeTextFieldDefST "copyright" L.copyright
    <@> freeTextFieldDefST "maintainer" L.maintainer
    <@> freeTextFieldDefST "author" L.author
    <@> freeTextFieldDefST "stability" L.stability
    <@> freeTextFieldDefST "homepage" L.homepage
    <@> freeTextFieldDefST "package-url" L.pkgUrl
    <@> freeTextFieldDefST "synopsis" L.synopsis
    <@> freeTextFieldDefST "description" L.description
    <@> freeTextFieldDefST "category" L.category
    -- Installed fields
    <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "")
    <@> booleanFieldDef "indefinite" L.indefinite False
    <@> booleanFieldDef "exposed" L.exposed False
    <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules
    <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules
    <@> booleanFieldDef "trusted" L.trusted False
    <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs
    <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs
    <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic
    <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs
    <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir ""
    <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries
    <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries
    <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic
    <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries
    <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs
    <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes
    <@> monoidalFieldAla "depends" (alaList FSep) L.depends
    <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends
    <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions
    <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions
    <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions
    <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs
    <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks
    <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces
    <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs
    <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot
  where
    mkInstalledPackageInfo _ Basic{..} =
      InstalledPackageInfo
        -- _basicPkgName is not used
        -- setMaybePackageId says it can be no-op.
        (PackageIdentifier pn _basicVersion)
        (combineLibraryName ln _basicLibName)
        (mkComponentId "") -- installedComponentId_, not in use
        _basicLibVisibility
      where
        MungedPackageName pn ln = _basicName
{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-}
{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-}
{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-}

-- (forall b. [b]) ~ ()
unitedList :: Lens' a [b]
unitedList f s = s <$ f []

-------------------------------------------------------------------------------
-- Helper functions
-------------------------------------------------------------------------------

-- | Combine 'LibraryName'. in parsing we prefer value coming
-- from munged @name@ field over the @lib-name@.
--
-- /Should/ be irrelevant.
combineLibraryName :: LibraryName -> LibraryName -> LibraryName
combineLibraryName l@(LSubLibName _) _ = l
combineLibraryName _ l = l

-- To maintain backwards-compatibility, we accept both comma/non-comma
-- separated variants of this field.  You SHOULD use the comma syntax if you
-- use any new functions, although actually it's unambiguous due to a quirk
-- of the fact that modules must start with capital letters.

showExposedModules :: [ExposedModule] -> Disp.Doc
showExposedModules xs
  | all isExposedModule xs = Disp.fsep (map pretty xs)
  | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs))
  where
    isExposedModule (ExposedModule _ Nothing) = True
    isExposedModule _ = False

-- | Setter for the @package-name@ field.  It should be acceptable for this
-- to be a no-op.
setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo
setMaybePackageName Nothing ipi = ipi
setMaybePackageName (Just pn) ipi =
  ipi
    { sourcePackageId = (sourcePackageId ipi){pkgName = pn}
    }

setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo
setMungedPackageName (MungedPackageName pn ln) ipi =
  ipi
    { sourcePackageId = (sourcePackageId ipi){pkgName = pn}
    , sourceLibName = ln
    }

--- | Returns @Just@ if the @name@ field of the IPI record would not contain
--- the package name verbatim.  This helps us avoid writing @package-name@
--- when it's redundant.
maybePackageName :: InstalledPackageInfo -> Maybe PackageName
maybePackageName ipi = case sourceLibName ipi of
  LMainLibName -> Nothing
  LSubLibName _ -> Just (packageName ipi)

-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------

newtype ExposedModules = ExposedModules {getExposedModules :: [ExposedModule]}

instance Newtype [ExposedModule] ExposedModules

instance Parsec ExposedModules where
  parsec = ExposedModules <$> parsecOptCommaList parsec

instance Pretty ExposedModules where
  pretty = showExposedModules . getExposedModules

newtype CompatPackageKey = CompatPackageKey {getCompatPackageKey :: String}

instance Newtype String CompatPackageKey

instance Pretty CompatPackageKey where
  pretty = Disp.text . getCompatPackageKey

instance Parsec CompatPackageKey where
  parsec = CompatPackageKey <$> P.munch1 uid_char
    where
      uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String)

newtype InstWith = InstWith {getInstWith :: [(ModuleName, OpenModule)]}

instance Newtype [(ModuleName, OpenModule)] InstWith

instance Pretty InstWith where
  pretty = dispOpenModuleSubst . Map.fromList . getInstWith

instance Parsec InstWith where
  parsec = InstWith . Map.toList <$> parsecOpenModuleSubst

-- | SPDX License expression or legacy license. Lenient parser, accepts either.
newtype SpecLicenseLenient = SpecLicenseLenient {getSpecLicenseLenient :: Either SPDX.License License}

instance Newtype (Either SPDX.License License) SpecLicenseLenient

instance Parsec SpecLicenseLenient where
  parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec

instance Pretty SpecLicenseLenient where
  pretty = either pretty pretty . getSpecLicenseLenient

-------------------------------------------------------------------------------
-- Basic fields
-------------------------------------------------------------------------------

-- | This type is used to mangle fields as
-- in serialised textual representation
-- to the actual 'InstalledPackageInfo' fields.
data Basic = Basic
  { _basicName :: MungedPackageName
  , _basicVersion :: Version
  , _basicPkgName :: Maybe PackageName
  , _basicLibName :: LibraryName
  , _basicLibVisibility :: LibraryVisibility
  }

basic :: Lens' InstalledPackageInfo Basic
basic f ipi = g <$> f b
  where
    b =
      Basic
        (mungedPackageName ipi)
        (packageVersion ipi)
        (maybePackageName ipi)
        (sourceLibName ipi)
        (libVisibility ipi)

    g (Basic n v pn ln lv) =
      ipi
        & setMungedPackageName n
        & L.sourcePackageId . L.pkgVersion .~ v
        & setMaybePackageName pn
        & L.sourceLibName .~ ln
        & L.libVisibility .~ lv

basicName :: Lens' Basic MungedPackageName
basicName f b = (\x -> b{_basicName = x}) <$> f (_basicName b)
{-# INLINE basicName #-}

basicVersion :: Lens' Basic Version
basicVersion f b = (\x -> b{_basicVersion = x}) <$> f (_basicVersion b)
{-# INLINE basicVersion #-}

basicPkgName :: Lens' Basic (Maybe PackageName)
basicPkgName f b = (\x -> b{_basicPkgName = x}) <$> f (_basicPkgName b)
{-# INLINE basicPkgName #-}

basicLibName :: Lens' Basic (Maybe UnqualComponentName)
basicLibName f b =
  (\x -> b{_basicLibName = maybeToLibraryName x})
    <$> f (libraryNameString (_basicLibName b))
{-# INLINE basicLibName #-}

basicLibVisibility :: Lens' Basic LibraryVisibility
basicLibVisibility f b =
  (\x -> b{_basicLibVisibility = x})
    <$> f (_basicLibVisibility b)
{-# INLINE basicLibVisibility #-}

basicFieldGrammar
  :: ( FieldGrammar c g
     , Applicative (g Basic)
     , c (Identity LibraryVisibility)
     , c (Identity PackageName)
     , c (Identity UnqualComponentName)
     , c (MQuoted MungedPackageName)
     , c (MQuoted Version)
     )
  => g Basic Basic
basicFieldGrammar =
  mkBasic
    <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
    <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion
    <*> optionalField "package-name" basicPkgName
    <*> optionalField "lib-name" basicLibName
    <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
  where
    mkBasic n v pn ln lv = Basic n v pn ln' lv'
      where
        ln' = maybe LMainLibName LSubLibName ln
        -- Older GHCs (<8.8) always report installed libraries as private
        -- because their ghc-pkg builds with an older Cabal.
        -- So we always set LibraryVisibilityPublic for main (unnamed) libs.
        -- This can be removed once we stop supporting GHC<8.8, at the
        -- condition that we keep marking main libraries as public when
        -- registering them.
        lv' =
          if let MungedPackageName _ mln = n
              in -- We need to check both because on ghc<8.2 ln' will always
                 -- be LMainLibName
                 ln' == LMainLibName && mln == LMainLibName
            then LibraryVisibilityPublic
            else lv