Update UnitId

This patch is quite raw.
- Effectively ComponentId and UnitId are very similar. I think UnitId should just be a newtype around ComponentId.
- We have Partial IDs, which should really be called Legacy, as they deal with non-compiler-prefixed ids.
- We need to modify the parsing of installed packages, to inject the compiler into unit-ids.
- We also need to modify parsing configure flags (--dependency=...) to ensure the ids are aligned.

Note: we need to support INTERNAL and EXTERNAL Setup.hs. (This shows up with --dependency=...) especially.

Author: angerman

Cabal-syntax/src/Distribution/Backpack.hs

@@ -53,6 +53,10 @@ import Distribution.Utils.Base62
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
 -----------------------------------------------------------------------
 -- OpenUnitId
 
@@ -147,9 +151,7 @@ mkOpenUnitId uid cid insts =
 mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
 mkDefUnitId cid insts =
   unsafeMkDefUnitId
-    ( mkUnitId
-        (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
-    )
+    (addSuffixToUnitId (maybe "" ("+" ++) (hashModuleSubst insts)) (unsafeCoerce cid))
 
 -- impose invariant!
 
@@ -254,7 +256,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems
 -- | When typechecking, we don't demand that a freshly instantiated
 -- 'IndefFullUnitId' be compiled; instead, we just depend on the
 -- installed indefinite unit installed at the 'ComponentId'.
-abstractUnitId :: OpenUnitId -> UnitId
+abstractUnitId :: HasCallStack => OpenUnitId -> UnitId
 abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
 abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
 

Cabal-syntax/src/Distribution/InstalledPackageInfo.hs

@@ -62,11 +62,15 @@ import qualified Text.PrettyPrint as Disp
 import Distribution.Types.InstalledPackageInfo
 import Distribution.Types.InstalledPackageInfo.FieldGrammar
 
-installedComponentId :: InstalledPackageInfo -> ComponentId
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
+installedComponentId :: HasCallStack => InstalledPackageInfo -> ComponentId
 installedComponentId ipi =
-  case unComponentId (installedComponentId_ ipi) of
-    "" -> mkComponentId (unUnitId (installedUnitId ipi))
-    _ -> installedComponentId_ ipi
+  fromMaybe
+    (unsafeCoerce (installedUnitId ipi))
+    (installedComponentId_ ipi)
 
 -- | Get the indefinite unit identity representing this package.
 -- This IS NOT guaranteed to give you a substitution; for
@@ -117,20 +121,20 @@ parseInstalledPackageInfo s = case P.readFields s of
 -- | Pretty print 'InstalledPackageInfo'.
 --
 -- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).
-showInstalledPackageInfo :: InstalledPackageInfo -> String
+showInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
 showInstalledPackageInfo ipi =
   showFullInstalledPackageInfo ipi{pkgRoot = Nothing}
 
 -- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
-showFullInstalledPackageInfo :: InstalledPackageInfo -> String
+showFullInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
 showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar
 
 -- |
 --
 -- >>> let ipi = emptyInstalledPackageInfo { maintainer = fromString "Tester" }
 -- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer"
 -- Just "maintainer: Tester"
-showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showInstalledPackageInfoField :: HasCallStack => String -> Maybe (InstalledPackageInfo -> String)
 showInstalledPackageInfoField fn =
   fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
 

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

@@ -17,6 +17,7 @@ import Distribution.Pretty
 import qualified Distribution.Compat.CharParsing as P
 import Text.PrettyPrint (text)
 
+import GHC.Stack (HasCallStack)
 -- | A 'ComponentId' uniquely identifies the transitive source
 -- code closure of a component (i.e. libraries, executables).
 --
@@ -30,8 +31,21 @@ import Text.PrettyPrint (text)
 -- This type is opaque since @Cabal-2.0@
 --
 -- @since 2.0.0.2
-newtype ComponentId = ComponentId ShortText
-  deriving (Generic, Read, Show, Eq, Ord, Data)
+data ComponentId = ComponentId ShortText ShortText Bool
+                 | PartialComponentId ShortText
+  deriving (Generic, Read, Show, Data)
+
+instance Eq ComponentId where
+  (ComponentId c1 s1 _) == (ComponentId c2 s2 _) = c1 == c2 && s1 == s2
+  (PartialComponentId s1) == (PartialComponentId s2) = s1 == s2
+  _ == _ = False
+
+instance Ord ComponentId where
+  compare (ComponentId c1 s1 _) (ComponentId c2 s2 _) = compare (c1, s1) (c2, s2)
+  compare (PartialComponentId s1) (PartialComponentId s2) = compare s1 s2
+  compare (PartialComponentId _) _ = LT
+  compare _ (PartialComponentId _) = GT
+
 
 -- | Construct a 'ComponentId' from a 'String'
 --
@@ -41,14 +55,25 @@ newtype ComponentId = ComponentId ShortText
 -- 'ComponentId' is valid
 --
 -- @since 2.0.0.2
-mkComponentId :: String -> ComponentId
-mkComponentId = ComponentId . toShortText
+mkComponentId :: HasCallStack => String -> ComponentId
+mkComponentId s = case (simpleParsec s) of
+    Just cid@ComponentId{} -> cid
+    Just cid@PartialComponentId{} -> error $ "mkPartialComponentId: `" ++ s ++ "' is a partial component id, not a full one."
+    _ -> error $ "Unable to parse PartialComponentId: `" ++ s ++ "'."
+
+mkComponentId' :: HasCallStack => String -> String -> Bool -> ComponentId
+mkComponentId' c i b = ComponentId (toShortText c) (toShortText i) b
+
+mkPartialComponentId :: HasCallStack => String -> ComponentId
+mkPartialComponentId s = PartialComponentId (toShortText s)
 
 -- | Convert 'ComponentId' to 'String'
 --
 -- @since 2.0.0.2
-unComponentId :: ComponentId -> String
-unComponentId (ComponentId s) = fromShortText s
+unComponentId :: HasCallStack => ComponentId -> String
+unComponentId (ComponentId c s False) = fromShortText c ++ '_':fromShortText s
+unComponentId (ComponentId c s True) = fromShortText s
+unComponentId (PartialComponentId s) = fromShortText s
 
 -- | 'mkComponentId'
 --
@@ -63,8 +88,12 @@ instance Pretty ComponentId where
   pretty = text . unComponentId
 
 instance Parsec ComponentId where
-  parsec = mkComponentId `fmap` P.munch1 abi_char
+  parsec = P.try (mkComponentId' <$> compid <* P.char '_' <*> P.munch1 abi_char <*> return False)
+        <|> mkPartialComponentId <$> P.munch1 abi_char
     where
+      compid = (\f v -> f ++ "-" ++ v) <$> P.munch1 isAlpha <* P.char '-' <*> P.munch1 isVerChar
+      isVerChar :: Char -> Bool
+      isVerChar c = c `elem` '.':['0'..'9']
       abi_char c = isAlphaNum c || c `elem` "-_."
 
 instance NFData ComponentId where

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

@@ -42,7 +42,7 @@ data InstalledPackageInfo = InstalledPackageInfo
     -- exactly the same as PackageDescription
     sourcePackageId :: PackageId
   , sourceLibName :: LibraryName
-  , installedComponentId_ :: ComponentId
+  , installedComponentId_ :: Maybe ComponentId
   , libVisibility :: LibraryVisibility
   , installedUnitId :: UnitId
   , -- INVARIANT: if this package is definite, OpenModule's
@@ -134,7 +134,7 @@ emptyInstalledPackageInfo =
   InstalledPackageInfo
     { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion Nothing
     , sourceLibName = LMainLibName
-    , installedComponentId_ = mkComponentId ""
+    , installedComponentId_ = Nothing
     , installedUnitId = mkUnitId ""
     , instantiatedWith = []
     , compatPackageKey = ""

Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs

@@ -40,6 +40,8 @@ import Distribution.Types.InstalledPackageInfo
 import qualified Distribution.Types.InstalledPackageInfo.Lens as L
 import qualified Distribution.Types.PackageId.Lens as L hiding (pkgCompiler)
 
+import GHC.Stack (HasCallStack)
+
 -- Note: GHC goes nuts and inlines everything,
 -- One can see e.g. in -ddump-simpl-stats:
 --
@@ -75,7 +77,7 @@ ipiFieldGrammar
      , c InstWith
      , c SpecLicenseLenient
      , c (Identity (Maybe CompilerId))
-     )
+     , HasCallStack )
   => g InstalledPackageInfo InstalledPackageInfo
 ipiFieldGrammar =
   mkInstalledPackageInfo
@@ -86,7 +88,10 @@ ipiFieldGrammar =
     -- Very basic fields: name, version, package-name, lib-name and visibility
     <@> blurFieldGrammar basic basicFieldGrammar
     -- Basic fields
-    <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "")
+    -- [note: forced default values]
+    -- Observe optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x
+    -- and optionalFieldDefAla will force x.
+    <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "invalid-invalid")
     <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
     <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
     <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
@@ -135,7 +140,7 @@ ipiFieldGrammar =
         -- setMaybePackageId says it can be no-op.
         (PackageIdentifier pn _basicVersion _basicCompilerId)
         (combineLibraryName ln _basicLibName)
-        (mkComponentId "") -- installedComponentId_, not in use
+        Nothing
         _basicLibVisibility
       where
         MungedPackageName pn ln = _basicName

Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs

@@ -28,7 +28,7 @@ installedUnitId :: Lens' InstalledPackageInfo UnitId
 installedUnitId f s = fmap (\x -> s{T.installedUnitId = x}) (f (T.installedUnitId s))
 {-# INLINE installedUnitId #-}
 
-installedComponentId_ :: Lens' InstalledPackageInfo ComponentId
+installedComponentId_ :: Lens' InstalledPackageInfo (Maybe ComponentId)
 installedComponentId_ f s = fmap (\x -> s{T.installedComponentId_ = x}) (f (T.installedComponentId_ s))
 {-# INLINE installedComponentId_ #-}
 

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

@@ -38,8 +38,9 @@ instance Structured PackageIdentifier
 
 instance Pretty PackageIdentifier where
   pretty (PackageIdentifier n v c)
-    | Just c' <- c, v == nullVersion = pretty c <<>> Disp.char ':' <<>> pretty n -- if no version, don't show version.
-    | Just c' <- c = pretty c' <<>> Disp.char ':' <<>> pretty n <<>> Disp.char '-' <<>> pretty v
+    -- we must never print the compiler, as other tools like hackage-security rely on the Pretty instance
+    -- | Just c' <- c, v == nullVersion = pretty c <<>> Disp.char ':' <<>> pretty n -- if no version, don't show version.
+    -- | Just c' <- c = pretty c' <<>> Disp.char ':' <<>> pretty n <<>> Disp.char '-' <<>> pretty v
     | v == nullVersion = pretty n
     | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
 

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

@@ -7,6 +7,9 @@ module Distribution.Types.UnitId
   ( UnitId
   , unUnitId
   , mkUnitId
+  , isPartialUnitId
+  , addPrefixToUnitId
+  , addSuffixToUnitId
   , DefUnitId
   , unsafeMkDefUnitId
   , unDefUnitId
@@ -27,6 +30,11 @@ import Distribution.Types.PackageId
 
 import Text.PrettyPrint (text)
 
+import GHC.Stack (HasCallStack)
+import Data.List (isInfixOf)
+
+import Unsafe.Coerce (unsafeCoerce)
+
 -- | A unit identifier identifies a (possibly instantiated)
 -- package/component that can be installed the installed package
 -- database.  There are several types of components that can be
@@ -63,11 +71,24 @@ import Text.PrettyPrint (text)
 -- representation of a UnitId to pass, e.g., as a @-package-id@
 -- flag, use the 'display' function, which will work on all
 -- versions of Cabal.
-newtype UnitId = UnitId ShortText
-  deriving (Generic, Read, Show, Eq, Ord, Data, NFData)
+data UnitId = UnitId ShortText ShortText Bool
+            | PartialUnitId ShortText
+  deriving (Generic, Read, Show, Data)
+
+instance Eq UnitId where
+  (UnitId c1 s1 _) == (UnitId c2 s2 _) = c1 == c2 && s1 == s2
+  (PartialUnitId s1) == (PartialUnitId s2) = s1 == s2
+  _ == _ = False
+
+instance Ord UnitId where
+  compare (UnitId c1 s1 _) (UnitId c2 s2 _) = compare (c1, s1) (c2, s2)
+  compare (PartialUnitId s1) (PartialUnitId s2) = compare s1 s2
+  compare (PartialUnitId _) _ = LT
+  compare _ (PartialUnitId _) = GT
 
 instance Binary UnitId
 instance Structured UnitId
+instance NFData UnitId
 
 -- | The textual format for 'UnitId' coincides with the format
 -- GHC accepts for @-package-id@.
@@ -77,22 +98,54 @@ instance Pretty UnitId where
 -- | The textual format for 'UnitId' coincides with the format
 -- GHC accepts for @-package-id@.
 instance Parsec UnitId where
-  parsec = mkUnitId <$> P.munch1 isUnitChar
+  parsec = P.try (mkUnitId' <$> compid <* P.char '_' <*> P.munch1 isUnitChar <*> return False)
+        <|> (mkPartialUnitId <$> P.munch1 isUnitChar)
     where
+      compid = (\f v -> f ++ "-" ++ v) <$> P.munch1 isAlpha <* P.char '-' <*> P.munch1 isVerChar
+      isVerChar :: Char -> Bool
+      isVerChar c = c `elem` '.':['0'..'9']
       -- https://gitlab.haskell.org/ghc/ghc/issues/17752
       isUnitChar '-' = True
       isUnitChar '_' = True
       isUnitChar '.' = True
       isUnitChar '+' = True
       isUnitChar c = isAlphaNum c
 
+isPartialUnitId :: HasCallStack => UnitId -> Bool
+isPartialUnitId (PartialUnitId _) = True
+isPartialUnitId _ = False
+
+addPrefixToUnitId :: HasCallStack => String -> UnitId -> UnitId
+addPrefixToUnitId prefix (PartialUnitId s) = UnitId (toShortText prefix) s True
+addPrefixToUnitId prefix uid@(UnitId _ _ _) = error $ "addPrefixToUnitId: UnitId " ++ show uid ++ " already has a prefix; can't add: " ++ prefix
+
+addSuffixToUnitId :: HasCallStack => String -> UnitId -> UnitId
+addSuffixToUnitId suffix (UnitId c s fromPartial) = UnitId c (s <> toShortText suffix) fromPartial
+addSuffixToUnitId suffix (PartialUnitId s) = PartialUnitId (s <> toShortText suffix)
+
+
+dropPrefixFromUnitId :: HasCallStack => UnitId -> UnitId
+dropPrefixFromUnitId (PartialUnitId s) = PartialUnitId s
+dropPrefixFromUnitId (UnitId _c s _fromPartial) = PartialUnitId s
+
 -- | If you need backwards compatibility, consider using 'display'
 -- instead, which is supported by all versions of Cabal.
-unUnitId :: UnitId -> String
-unUnitId (UnitId s) = fromShortText s
+unUnitId :: HasCallStack => UnitId -> String
+unUnitId (UnitId c s False) = fromShortText c ++ '_':fromShortText s
+unUnitId (UnitId c s True) = fromShortText s
+unUnitId (PartialUnitId s) = fromShortText s
+
+mkUnitId :: HasCallStack => String -> UnitId
+mkUnitId s = case (simpleParsec s) of
+    Just uid@UnitId{} -> uid
+    Just uid@PartialUnitId{} -> uid -- error $ "mkUnitId: `" ++ s ++ "' is a partial unit id, not a full one."
+    _ -> error $ "Unable to parse UnitId: `" ++ s ++ "'."
+
+mkUnitId' :: HasCallStack => String -> String -> Bool -> UnitId
+mkUnitId' c i b = UnitId (toShortText c) (toShortText i) b
 
-mkUnitId :: String -> UnitId
-mkUnitId = UnitId . toShortText
+mkPartialUnitId :: HasCallStack => String -> UnitId
+mkPartialUnitId s = PartialUnitId (toShortText s)
 
 -- | 'mkUnitId'
 --
@@ -102,17 +155,17 @@ instance IsString UnitId where
 
 -- | Create a unit identity with no associated hash directly
 -- from a 'ComponentId'.
-newSimpleUnitId :: ComponentId -> UnitId
-newSimpleUnitId = mkUnitId . unComponentId
+newSimpleUnitId :: HasCallStack => ComponentId -> UnitId
+newSimpleUnitId = unsafeCoerce
 
 -- | Make an old-style UnitId from a package identifier.
 -- Assumed to be for the public library
-mkLegacyUnitId :: PackageId -> UnitId
+mkLegacyUnitId :: HasCallStack => PackageId -> UnitId
 mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow
 
 -- | Returns library name prefixed with HS, suitable for filenames
 getHSLibraryName :: UnitId -> String
-getHSLibraryName uid = "HS" ++ prettyShow uid
+getHSLibraryName uid = "HS" ++ prettyShow (dropPrefixFromUnitId uid)
 
 -- | A 'UnitId' for a definite package.  The 'DefUnitId' invariant says
 -- that a 'UnitId' identified this way is definite; i.e., it has no