Cabal-syntax/src/Distribution/Types/MungedPackageName.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3
   4 module Distribution.Types.MungedPackageName
   5   ( MungedPackageName (..)
   6   , decodeCompatPackageName
   7   , encodeCompatPackageName
   8   ) where
   9
  10 import Distribution.Compat.Prelude
  11 import Prelude ()
  12
  13 import Distribution.Parsec
  14 import Distribution.Pretty
  15 import Distribution.Types.LibraryName
  16 import Distribution.Types.PackageName
  17 import Distribution.Types.UnqualComponentName
  18
  19 import qualified Distribution.Compat.CharParsing as P
  20 import qualified Text.PrettyPrint as Disp
  21
  22 -- | A combination of a package and component name used in various legacy
  23 -- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally
  24 -- better to use a 'UnitId' to opaquely refer to some compilation/packing unit,
  25 -- but that doesn't always work, e.g. where a "name" is needed, in which case
  26 -- this can be used as a fallback.
  27 --
  28 -- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'.
  29 --
  30 -- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation.
  31 --
  32 -- @since 2.0.0.2
  33 data MungedPackageName = MungedPackageName !PackageName !LibraryName
  34   deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
  35
  36 instance Binary MungedPackageName
  37 instance Structured MungedPackageName
  38 instance NFData MungedPackageName where rnf = genericRnf
  39
  40 -- | Computes the package name for a library.  If this is the public
  41 -- library, it will just be the original package name; otherwise,
  42 -- it will be a munged package name recording the original package
  43 -- name as well as the name of the internal library.
  44 --
  45 -- A lot of tooling in the Haskell ecosystem assumes that if something
  46 -- is installed to the package database with the package name 'foo',
  47 -- then it actually is an entry for the (only public) library in package
  48 -- 'foo'.  With internal packages, this is not necessarily true:
  49 -- a public library as well as arbitrarily many internal libraries may
  50 -- come from the same package.  To prevent tools from getting confused
  51 -- in this case, the package name of these internal libraries is munged
  52 -- so that they do not conflict the public library proper.  A particular
  53 -- case where this matters is ghc-pkg: if we don't munge the package
  54 -- name, the inplace registration will OVERRIDE a different internal
  55 -- library.
  56 --
  57 -- We munge into a reserved namespace, "z-", and encode both the
  58 -- component name and the package name of an internal library using the
  59 -- following format:
  60 --
  61 --      compat-pkg-name ::= "z-" package-name "-z-" library-name
  62 --
  63 -- where package-name and library-name have "-" ( "z" + ) "-"
  64 -- segments encoded by adding an extra "z".
  65 --
  66 -- When we have the public library, the compat-pkg-name is just the
  67 -- package-name, no surprises there!
  68 --
  69 -- >>> prettyShow $ MungedPackageName "servant" LMainLibName
  70 -- "servant"
  71 --
  72 -- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey")
  73 -- "z-servant-z-lackey"
  74 instance Pretty MungedPackageName where
  75   -- First handle the cases where we can just use the original 'PackageName'.
  76   -- This is for the PRIMARY library, and it is non-Backpack, or the
  77   -- indefinite package for us.
  78   pretty = Disp.text . encodeCompatPackageName'
  79
  80 -- |
  81 --
  82 -- >>> simpleParsec "servant" :: Maybe MungedPackageName
  83 -- Just (MungedPackageName (PackageName "servant") LMainLibName)
  84 --
  85 -- >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName
  86 -- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")))
  87 --
  88 -- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName
  89 -- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName)
  90 instance Parsec MungedPackageName where
  91   parsec = decodeCompatPackageName' <$> parsecUnqualComponentName
  92
  93 -------------------------------------------------------------------------------
  94 -- ZDashCode conversions
  95 -------------------------------------------------------------------------------
  96
  97 -- | Intended for internal use only
  98 --
  99 -- >>> decodeCompatPackageName "z-servant-z-lackey"
 100 -- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))
 101 decodeCompatPackageName :: PackageName -> MungedPackageName
 102 decodeCompatPackageName = decodeCompatPackageName' . unPackageName
 103
 104 -- | Intended for internal use only
 105 --
 106 -- >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey")
 107 -- PackageName "z-servant-z-lackey"
 108 --
 109 -- This is used in @cabal-install@ in the Solver.
 110 -- May become obsolete as solver moves to per-component solving.
 111 encodeCompatPackageName :: MungedPackageName -> PackageName
 112 encodeCompatPackageName = mkPackageName . encodeCompatPackageName'
 113
 114 decodeCompatPackageName' :: String -> MungedPackageName
 115 decodeCompatPackageName' m =
 116   case m of
 117     'z' : '-' : rest
 118       | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest ->
 119           MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn))
 120     s -> MungedPackageName (mkPackageName s) LMainLibName
 121
 122 encodeCompatPackageName' :: MungedPackageName -> String
 123 encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn
 124 encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) =
 125   "z-"
 126     ++ zdashcode (unPackageName pn)
 127     ++ "-z-"
 128     ++ zdashcode (unUnqualComponentName uqn)
 129
 130 zdashcode :: String -> String
 131 zdashcode s = go s (Nothing :: Maybe Int) []
 132   where
 133     go [] _ r = reverse r
 134     go ('-' : z) (Just n) r | n > 0 = go z (Just 0) ('-' : 'z' : r)
 135     go ('-' : z) _ r = go z (Just 0) ('-' : r)
 136     go ('z' : z) (Just n) r = go z (Just (n + 1)) ('z' : r)
 137     go (c : z) _ r = go z Nothing (c : r)
 138
 139 parseZDashCode :: CabalParsing m => m [String]
 140 parseZDashCode = do
 141   ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-')
 142   return (go ns)
 143   where
 144     go ns = case break (== "z") ns of
 145       (_, []) -> [paste ns]
 146       (as, "z" : bs) -> paste as : go bs
 147       _ -> error "parseZDashCode: go"
 148     unZ :: String -> String
 149     unZ "" = error "parseZDashCode: unZ"
 150     unZ r@('z' : zs)
 151       | all (== 'z') zs = zs
 152       | otherwise = r
 153     unZ r = r
 154     paste :: [String] -> String
 155     paste = intercalate "-" . map unZ
 156
 157 -- $setup
 158 -- >>> :seti -XOverloadedStrings