{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.Id(
    computeComponentId,
    computeCompatPackageKey,
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.UnqualComponentName
import Distribution.Simple.Compiler
import Distribution.PackageDescription
import Distribution.Simple.Setup as Setup
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.ComponentId
import Distribution.Types.UnitId
import Distribution.Types.MungedPackageName
import Distribution.Utils.Base62
import Distribution.Version

import Distribution.Pretty
    ( prettyShow )
import Distribution.Parsec ( simpleParsec )

-- | This method computes a default, "good enough" 'ComponentId'
-- for a package.  The intent is that cabal-install (or the user) will
-- specify a more detailed IPID via the @--ipid@ flag if necessary.
computeComponentId
    :: Bool -- deterministic mode
    -> Flag String
    -> Flag ComponentId
    -> PackageIdentifier
    -> ComponentName
    -- This is used by cabal-install's legacy codepath
    -> Maybe ([ComponentId], FlagAssignment)
    -> ComponentId
computeComponentId :: Bool
-> Flag String
-> Flag ComponentId
-> PackageIdentifier
-> ComponentName
-> Maybe ([ComponentId], FlagAssignment)
-> ComponentId
computeComponentId Bool
deterministic Flag String
mb_ipid Flag ComponentId
mb_cid PackageIdentifier
pid ComponentName
cname Maybe ([ComponentId], FlagAssignment)
mb_details =
    -- show is found to be faster than intercalate and then replacement of
    -- special character used in intercalating. We cannot simply hash by
    -- doubly concatenating list, as it just flatten out the nested list, so
    -- different sources can produce same hash
    let hash_suffix :: String
hash_suffix
            | Just ([ComponentId]
dep_ipids, FlagAssignment
flags) <- Maybe ([ComponentId], FlagAssignment)
mb_details
            = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
hashToBase62
                -- For safety, include the package + version here
                -- for GHC 7.10, where just the hash is used as
                -- the package key
                    (    PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ComponentId] -> String
forall a. Show a => a -> String
show [ComponentId]
dep_ipids
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ FlagAssignment -> String
forall a. Show a => a -> String
show FlagAssignment
flags     )
            | Bool
otherwise = String
""
        generated_base :: String
generated_base = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hash_suffix
        explicit_base :: String -> String
explicit_base String
cid0 = PathTemplate -> String
fromPathTemplate (PathTemplateEnv -> PathTemplate -> PathTemplate
InstallDirs.substPathTemplate PathTemplateEnv
env
                                                    (String -> PathTemplate
toPathTemplate String
cid0))
            -- Hack to reuse install dirs machinery
            -- NB: no real IPID available at this point
          where env :: PathTemplateEnv
env = PackageIdentifier -> UnitId -> PathTemplateEnv
packageTemplateEnv PackageIdentifier
pid (String -> UnitId
mkUnitId String
"")
        actual_base :: String
actual_base = case Flag String
mb_ipid of
                        Flag String
ipid0 -> String -> String
explicit_base String
ipid0
                        Flag String
NoFlag | Bool
deterministic -> PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid
                               | Bool
otherwise     -> String
generated_base
    in case Flag ComponentId
mb_cid of
          Flag ComponentId
cid -> ComponentId
cid
          Flag ComponentId
NoFlag -> String -> ComponentId
mkComponentId (String -> ComponentId) -> String -> ComponentId
forall a b. (a -> b) -> a -> b
$ String
actual_base
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
cname of
                                Maybe UnqualComponentName
Nothing -> String
""
                                Just UnqualComponentName
s -> String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
s)

-- | In GHC 8.0, the string we pass to GHC to use for symbol
-- names for a package can be an arbitrary, IPID-compatible string.
-- However, prior to GHC 8.0 there are some restrictions on what
-- format this string can be (due to how ghc-pkg parsed the key):
--
--      1. In GHC 7.10, the string had either be of the form
--      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated
--      prefix and ABCD is two base-64 encoded 64-bit integers,
--      or a GHC 7.8 style identifier.
--
--      2. In GHC 7.8, the string had to be a valid package identifier
--      like foo-0.1.
--
-- So, the problem is that Cabal, in general, has a general IPID,
-- but needs to figure out a package key / package ID that the
-- old ghc-pkg will actually accept.  But there's an EVERY WORSE
-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx
-- as if it were a package identifier, which means it will SILENTLY
-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)
-- So we must CONNIVE to ensure that we don't pick something that
-- looks like this.
--
-- So this function attempts to define a mapping into the old formats.
--
-- The mapping for GHC 7.8 and before:
--
--      * We use the *compatibility* package name and version.  For
--        public libraries this is just the package identifier; for
--        internal libraries, it's something like "z-pkgname-z-libname-0.1".
--        See 'computeCompatPackageName' for more details.
--
-- The mapping for GHC 7.10:
--
--      * For CLibName:
--          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would
--          validly parse as a package key, we pass "ABCDEF".  (NB: not
--          all hashes parse this way, because GHC 7.10 mandated that
--          these hashes be two base-62 encoded 64 bit integers),
--          but hashes that Cabal generated using 'computeComponentId'
--          are guaranteed to have this form.
--
--          If it is not of this form, we rehash the IPID into the
--          correct form and pass that.
--
--      * For sub-components, we rehash the IPID into the correct format
--        and pass that.
--
computeCompatPackageKey
    :: Compiler
    -> MungedPackageName
    -> Version
    -> UnitId
    -> String
computeCompatPackageKey :: Compiler -> MungedPackageName -> Version -> UnitId -> String
computeCompatPackageKey Compiler
comp MungedPackageName
pkg_name Version
pkg_version UnitId
uid
    | Bool -> Bool
not (Compiler -> Bool
packageKeySupported Compiler
comp Bool -> Bool -> Bool
|| Compiler -> Bool
unitIdSupported Compiler
comp)
    = MungedPackageName -> String
forall a. Pretty a => a -> String
prettyShow MungedPackageName
pkg_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
pkg_version
    | Bool -> Bool
not (Compiler -> Bool
unifiedIPIDRequired Compiler
comp) =
        let str :: String
str = UnitId -> String
unUnitId UnitId
uid -- assume no Backpack support
            mb_verbatim_key :: Maybe String
mb_verbatim_key
                = case String -> Maybe PackageIdentifier
forall a. Parsec a => String -> Maybe a
simpleParsec String
str :: Maybe PackageId of
                    -- Something like 'foo-0.1', use it verbatim.
                    -- (NB: hash tags look like tags, so they are parsed,
                    -- so the extra equality check tests if a tag was dropped.)
                    Just PackageIdentifier
pid0 | PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid0 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str -> String -> Maybe String
forall a. a -> Maybe a
Just String
str
                    Maybe PackageIdentifier
_ -> Maybe String
forall a. Maybe a
Nothing
            mb_truncated_key :: Maybe String
mb_truncated_key
                = let cand :: String
cand = String -> String
forall a. [a] -> [a]
reverse ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum (String -> String
forall a. [a] -> [a]
reverse String
str))
                  in if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cand Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
22 Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum String
cand
                        then String -> Maybe String
forall a. a -> Maybe a
Just String
cand
                        else Maybe String
forall a. Maybe a
Nothing
            rehashed_key :: String
rehashed_key = String -> String
hashToBase62 String
str
        in String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
rehashed_key (Maybe String
mb_verbatim_key Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String
mb_truncated_key)
    | Bool
otherwise = UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid