MungedPackageName.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Types.MungedPackageName
  ( MungedPackageName, unMungedPackageName, mkMungedPackageName
  , computeCompatPackageName
  , decodeCompatPackageName
  ) where

import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText

import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import Distribution.ParseUtils
import Distribution.Text
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName

-- | A combination of a package and component name used in various legacy
-- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally
-- better to use a 'UnitId' to opaquely refer to some compilation/packing unit,
-- but that doesn't always work, e.g. where a "name" is needed, in which case
-- this can be used as a fallback.
--
-- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'.
--
-- @since 2.0
newtype MungedPackageName = MungedPackageName ShortText
    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)

-- | Convert 'MungedPackageName' to 'String'
unMungedPackageName :: MungedPackageName -> String
unMungedPackageName (MungedPackageName s) = fromShortText s

-- | Construct a 'MungedPackageName' from a 'String'
--
-- 'mkMungedPackageName' is the inverse to 'unMungedPackageName'
--
-- Note: No validations are performed to ensure that the resulting
-- 'MungedPackageName' is valid
--
-- @since 2.0
mkMungedPackageName :: String -> MungedPackageName
mkMungedPackageName = MungedPackageName . toShortText

-- | 'mkMungedPackageName'
--
-- @since 2.0
instance IsString MungedPackageName where
  fromString = mkMungedPackageName

instance Binary MungedPackageName

instance Text MungedPackageName where
  disp = Disp.text . unMungedPackageName
  parse = mkMungedPackageName <$> parsePackageName

instance NFData MungedPackageName where
    rnf (MungedPackageName pkg) = rnf pkg

-- | Computes the package name for a library.  If this is the public
-- library, it will just be the original package name; otherwise,
-- it will be a munged package name recording the original package
-- name as well as the name of the internal library.
--
-- A lot of tooling in the Haskell ecosystem assumes that if something
-- is installed to the package database with the package name 'foo',
-- then it actually is an entry for the (only public) library in package
-- 'foo'.  With internal packages, this is not necessarily true:
-- a public library as well as arbitrarily many internal libraries may
-- come from the same package.  To prevent tools from getting confused
-- in this case, the package name of these internal libraries is munged
-- so that they do not conflict the public library proper.  A particular
-- case where this matters is ghc-pkg: if we don't munge the package
-- name, the inplace registration will OVERRIDE a different internal
-- library.
--
-- We munge into a reserved namespace, "z-", and encode both the
-- component name and the package name of an internal library using the
-- following format:
--
--      compat-pkg-name ::= "z-" package-name "-z-" library-name
--
-- where package-name and library-name have "-" ( "z" + ) "-"
-- segments encoded by adding an extra "z".
--
-- When we have the public library, the compat-pkg-name is just the
-- package-name, no surprises there!
--
computeCompatPackageName :: PackageName -> Maybe UnqualComponentName -> MungedPackageName
-- First handle the cases where we can just use the original 'PackageName'.
-- This is for the PRIMARY library, and it is non-Backpack, or the
-- indefinite package for us.
computeCompatPackageName pkg_name Nothing
    = mkMungedPackageName $ unPackageName pkg_name
computeCompatPackageName pkg_name (Just uqn)
    = mkMungedPackageName $
         "z-" ++ zdashcode (unPackageName pkg_name) ++
        "-z-" ++ zdashcode (unUnqualComponentName uqn)

decodeCompatPackageName :: MungedPackageName -> (PackageName, Maybe UnqualComponentName)
decodeCompatPackageName m =
    case unMungedPackageName m of
        'z':'-':rest | [([pn, cn], "")] <- Parse.readP_to_S parseZDashCode rest
            -> (mkPackageName pn, Just (mkUnqualComponentName cn))
        s   -> (mkPackageName s, Nothing)

zdashcode :: String -> String
zdashcode s = go s (Nothing :: Maybe Int) []
    where go [] _ r = reverse r
          go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)
          go ('-':z) _        r = go z (Just 0) ('-':r)
          go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)
          go (c:z)   _        r = go z Nothing (c:r)

parseZDashCode :: Parse.ReadP r [String]
parseZDashCode = do
    ns <- Parse.sepBy1 (Parse.many1 (Parse.satisfy (/= '-'))) (Parse.char '-')
    Parse.eof
    return (go ns)
  where
    go ns = case break (=="z") ns of
                (_, []) -> [paste ns]
                (as, "z":bs) -> paste as : go bs
                _ -> error "parseZDashCode: go"
    unZ :: String -> String
    unZ "" = error "parseZDashCode: unZ"
    unZ r@('z':zs) | all (=='z') zs = zs
                   | otherwise      = r
    unZ r = r
    paste :: [String] -> String
    paste = intercalate "-" . map unZ