fixup register SDPX with GHC >= 8.4 [ci skip]

Author: phadej

Cabal/Distribution/License.hs

@@ -46,6 +46,7 @@ module Distribution.License (
     License(..),
     knownLicenses,
     licenseToSPDX,
+    licenseFromSPDX,
   ) where
 
 import Distribution.Compat.Prelude
@@ -57,6 +58,7 @@ import Distribution.Text
 import Distribution.Version
 
 import qualified Distribution.Compat.CharParsing as P
+import qualified Distribution.Compat.Map.Strict  as Map
 import qualified Distribution.Compat.ReadP       as Parse
 import qualified Distribution.SPDX               as SPDX
 import qualified Text.PrettyPrint                as Disp
@@ -142,7 +144,7 @@ knownLicenses = [ GPL  unversioned, GPL  (version [2]),    GPL  (version [3])
     unversioned = Nothing
     version     = Just . mkVersion
 
--- | Convert old 'License' to SPDX 'SPDX.LicenseExpression'.
+-- | Convert old 'License' to SPDX 'SPDX.License'.
 -- Non-SPDX licenses are converted to 'SPDX.LicenseRef'.
 --
 -- @since 2.2.0.0
@@ -171,6 +173,47 @@ licenseToSPDX l = case l of
     spdx    = SPDX.License . SPDX.simpleLicenseExpression
     ref  r  = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing
 
+-- | Convert 'SPDX.License' to 'License',
+--
+-- This is lossy conversion. We try our best.
+--
+-- >>> licenseFromSPDX . licenseToSPDX $ BSD3
+-- BSD3
+--
+-- >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3]))
+-- GPL (Just (mkVersion [3]))
+--
+-- >>> licenseFromSPDX . licenseToSPDX $ PublicDomain
+-- UnknownLicense "LicenseRefPublicDomain"
+--
+-- >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1
+-- UnknownLicense "EUPL-1.1"
+--
+-- >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved
+-- AllRightsReserved
+--
+-- >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0"
+-- Just (UnknownLicense "BSD3ClauseORGPL30")
+--
+-- @since 2.2.0.0
+licenseFromSPDX :: SPDX.License -> License
+licenseFromSPDX SPDX.NONE = AllRightsReserved
+licenseFromSPDX l =
+    fromMaybe (mungle $ prettyShow l) $ Map.lookup l m
+  where
+    m :: Map.Map SPDX.License License
+    m = Map.fromList $ filter (isSimple . fst ) $
+        map (\x -> (licenseToSPDX x, x)) knownLicenses
+
+    isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True
+    isSimple _ = False
+
+    mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name)
+
+    mangle c
+        | isAlphaNum c = Just c
+        | otherwise = Nothing
+
 instance Pretty License where
   pretty (GPL  version)         = Disp.text "GPL"    <<>> dispOptVersion version
   pretty (LGPL version)         = Disp.text "LGPL"   <<>> dispOptVersion version

Cabal/Distribution/SPDX/License.hs

@@ -41,7 +41,7 @@ data License
       -- ^ if the package contains no license information whatsoever; or
     | License LicenseExpression
       -- ^ A valid SPDX License Expression as defined in Appendix IV.
-  deriving (Show, Read, Eq, Typeable, Data, Generic)
+  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
 instance Binary License
 

Cabal/Distribution/SPDX/LicenseExpression.hs

@@ -42,7 +42,7 @@ data LicenseExpression
     = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId)
     | EAnd !LicenseExpression !LicenseExpression
     | EOr !LicenseExpression !LicenseExpression
-    deriving (Show, Read, Eq, Typeable, Data, Generic)
+    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
 -- | Simple License Expressions.
 data SimpleLicenseExpression
@@ -52,7 +52,7 @@ data SimpleLicenseExpression
       -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version.  For example: @GPL-2.0+@
     | ELicenseRef LicenseRef
       -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@
-    deriving (Show, Read, Eq, Typeable, Data, Generic)
+    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
 simpleLicenseExpression :: LicenseId -> LicenseExpression
 simpleLicenseExpression i = ELicense (ELicenseId i) Nothing

Cabal/Distribution/SPDX/LicenseReference.hs

@@ -23,7 +23,7 @@ data LicenseRef = LicenseRef
     { _lrDocument :: !(Maybe String)
     , _lrLicense  :: !String
     }
-  deriving (Show, Read, Eq, Typeable, Data, Generic)
+  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
 -- | License reference.
 licenseRef :: LicenseRef -> String

Cabal/Distribution/Simple/Register.hs

@@ -74,6 +74,7 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg
 import Distribution.Simple.Setup
 import Distribution.PackageDescription
 import Distribution.Package
+import Distribution.License (licenseToSPDX, licenseFromSPDX)
 import qualified Distribution.InstalledPackageInfo as IPI
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import Distribution.Simple.Utils
@@ -407,7 +408,11 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
     IPI.instantiatedWith   = componentInstantiatedWith clbi,
     IPI.sourceLibName      = libName lib,
     IPI.compatPackageKey   = componentCompatPackageKey clbi,
-    IPI.license            = licenseRaw  pkg,
+    -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
+    IPI.license            =
+        if ghc84
+        then Left $ either id licenseToSPDX $ licenseRaw pkg
+        else Right $ either licenseFromSPDX id $ licenseRaw pkg,
     IPI.copyright          = copyright   pkg,
     IPI.maintainer         = maintainer  pkg,
     IPI.author             = author      pkg,
@@ -450,6 +455,10 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
     IPI.pkgRoot            = Nothing
   }
   where
+    ghc84 = case compilerId $ compiler lbi of
+        CompilerId GHC v -> v >= mkVersion [8, 4]
+        _                -> False
+
     bi = libBuildInfo lib
     --TODO: unclear what the root cause of the
     -- duplication is, but we nub it here for now:

cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main

@@ -1,6 +1,7 @@
 import Test.Cabal.Prelude
 main = setupAndCabalTest $ withPackageDb $ do
     setup_install []
-    -- TODO: fix, should contain BSD-3-Clause
-    ghcPkg' "field" ["my", "license"] >>= assertOutputContains "BSD-3"
-    ghcPkg' "describe" ["my"] >>= assertOutputContains "BSD-3"
+    recordMode DoNotRecord $ do
+        ghc84 <- ghcVersionIs (>= mkVersion [8,4])
+        let lic = if ghc84 then "BSD-3-Clause" else "BSD3"
+        ghcPkg' "field" ["my", "license"] >>= assertOutputContains lic