    {-# 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 concating 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 (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 (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