-- | How to name the debian packages based on the cabal package name and version number.
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}
module Debian.Debianize.DebianName
    ( debianName
    , debianNameBase
    , mkPkgName
    , mkPkgName'
    , mapCabal
    , splitCabal
    , remapCabal
    ) where


import Control.Lens
import Data.Char (toLower)
import Data.Map as Map (alter, lookup)
import Debian.Debianize.Monad (CabalT)
import Debian.Debianize.CabalInfo as A (debianNameMap, packageDescription, debInfo)
import Debian.Debianize.BinaryDebDescription as Debian (PackageType(..))
import Debian.Debianize.DebInfo as D (overrideDebianNameBase, utilsPackageNameBase)
import Debian.Debianize.VersionSplits (DebBase(DebBase, unDebBase), doSplits, insertSplit, makePackage, VersionSplits(oldestPackage, splits))
import Debian.Orphans ()
import Debian.Relation (PkgName(..), Relations)
import qualified Debian.Relation as D (VersionReq(EEQ))
import Debian.Version (parseDebianVersion')
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName, unPackageName)
import Distribution.Version (Version)
import qualified Distribution.PackageDescription as Cabal (PackageDescription(package))
import Distribution.Pretty (prettyShow)
import Prelude hiding (unlines)

data Dependency_
  = BuildDepends Dependency
  | BuildTools Dependency
  | PkgConfigDepends Dependency
  | ExtraLibs Relations
    deriving (Dependency_ -> Dependency_ -> Bool
(Dependency_ -> Dependency_ -> Bool)
-> (Dependency_ -> Dependency_ -> Bool) -> Eq Dependency_
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dependency_ -> Dependency_ -> Bool
$c/= :: Dependency_ -> Dependency_ -> Bool
== :: Dependency_ -> Dependency_ -> Bool
$c== :: Dependency_ -> Dependency_ -> Bool
Eq, Int -> Dependency_ -> ShowS
[Dependency_] -> ShowS
Dependency_ -> String
(Int -> Dependency_ -> ShowS)
-> (Dependency_ -> String)
-> ([Dependency_] -> ShowS)
-> Show Dependency_
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependency_] -> ShowS
$cshowList :: [Dependency_] -> ShowS
show :: Dependency_ -> String
$cshow :: Dependency_ -> String
showsPrec :: Int -> Dependency_ -> ShowS
$cshowsPrec :: Int -> Dependency_ -> ShowS
Show)

-- | Build the Debian package name for a given package type.
debianName :: (Monad m, PkgName name) => PackageType -> CompilerFlavor -> CabalT m name
debianName :: PackageType -> CompilerFlavor -> CabalT m name
debianName PackageType
typ CompilerFlavor
hc =
    do String
base <-
           case (PackageType
typ, CompilerFlavor
hc) of
             (PackageType
Utilities, CompilerFlavor
GHC) -> Getting (Maybe String) CabalInfo (Maybe String)
-> StateT CabalInfo m (Maybe String)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((DebInfo -> Const (Maybe String) DebInfo)
-> CabalInfo -> Const (Maybe String) CabalInfo
Lens' CabalInfo DebInfo
debInfo ((DebInfo -> Const (Maybe String) DebInfo)
 -> CabalInfo -> Const (Maybe String) CabalInfo)
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> DebInfo -> Const (Maybe String) DebInfo)
-> Getting (Maybe String) CabalInfo (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Const (Maybe String) (Maybe String))
-> DebInfo -> Const (Maybe String) DebInfo
Lens' DebInfo (Maybe String)
utilsPackageNameBase) StateT CabalInfo m (Maybe String)
-> (Maybe String -> StateT CabalInfo m String)
-> StateT CabalInfo m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT CabalInfo m String
-> (String -> StateT CabalInfo m String)
-> Maybe String
-> StateT CabalInfo m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((\ String
base -> String
"haskell-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-utils") ShowS -> (DebBase -> String) -> DebBase -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebBase -> String
unDebBase) (DebBase -> String)
-> StateT CabalInfo m DebBase -> StateT CabalInfo m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CabalInfo m DebBase
forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase) String -> StateT CabalInfo m String
forall (m :: * -> *) a. Monad m => a -> m a
return
             (PackageType
Utilities, CompilerFlavor
_) -> Getting (Maybe String) CabalInfo (Maybe String)
-> StateT CabalInfo m (Maybe String)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((DebInfo -> Const (Maybe String) DebInfo)
-> CabalInfo -> Const (Maybe String) CabalInfo
Lens' CabalInfo DebInfo
debInfo ((DebInfo -> Const (Maybe String) DebInfo)
 -> CabalInfo -> Const (Maybe String) CabalInfo)
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> DebInfo -> Const (Maybe String) DebInfo)
-> Getting (Maybe String) CabalInfo (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Const (Maybe String) (Maybe String))
-> DebInfo -> Const (Maybe String) DebInfo
Lens' DebInfo (Maybe String)
utilsPackageNameBase) StateT CabalInfo m (Maybe String)
-> (Maybe String -> StateT CabalInfo m String)
-> StateT CabalInfo m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT CabalInfo m String
-> (String -> StateT CabalInfo m String)
-> Maybe String
-> StateT CabalInfo m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((\ String
base -> String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-utils") ShowS -> (DebBase -> String) -> DebBase -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebBase -> String
unDebBase) (DebBase -> String)
-> StateT CabalInfo m DebBase -> StateT CabalInfo m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CabalInfo m DebBase
forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase) String -> StateT CabalInfo m String
forall (m :: * -> *) a. Monad m => a -> m a
return
             (PackageType, CompilerFlavor)
_ -> DebBase -> String
unDebBase (DebBase -> String)
-> StateT CabalInfo m DebBase -> StateT CabalInfo m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CabalInfo m DebBase
forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase
       name -> CabalT m name
forall (m :: * -> *) a. Monad m => a -> m a
return (name -> CabalT m name) -> name -> CabalT m name
forall a b. (a -> b) -> a -> b
$ CompilerFlavor -> PackageType -> DebBase -> name
forall name.
PkgName name =>
CompilerFlavor -> PackageType -> DebBase -> name
mkPkgName' CompilerFlavor
hc PackageType
typ (String -> DebBase
DebBase String
base)

-- | Function that applies the mapping from cabal names to debian
-- names based on version numbers.  If a version split happens at v,
-- this will return the ltName if < v, and the geName if the relation
-- is >= v.
debianNameBase :: Monad m => CabalT m DebBase
debianNameBase :: CabalT m DebBase
debianNameBase =
    do Maybe DebBase
nameBase <- Getting (Maybe DebBase) CabalInfo (Maybe DebBase)
-> StateT CabalInfo m (Maybe DebBase)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((DebInfo -> Const (Maybe DebBase) DebInfo)
-> CabalInfo -> Const (Maybe DebBase) CabalInfo
Lens' CabalInfo DebInfo
debInfo ((DebInfo -> Const (Maybe DebBase) DebInfo)
 -> CabalInfo -> Const (Maybe DebBase) CabalInfo)
-> ((Maybe DebBase -> Const (Maybe DebBase) (Maybe DebBase))
    -> DebInfo -> Const (Maybe DebBase) DebInfo)
-> Getting (Maybe DebBase) CabalInfo (Maybe DebBase)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe DebBase -> Const (Maybe DebBase) (Maybe DebBase))
-> DebInfo -> Const (Maybe DebBase) DebInfo
Lens' DebInfo (Maybe DebBase)
D.overrideDebianNameBase)
       PackageDescription
pkgDesc <- Getting PackageDescription CabalInfo PackageDescription
-> StateT CabalInfo m PackageDescription
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting PackageDescription CabalInfo PackageDescription
Lens' CabalInfo PackageDescription
packageDescription
       let pkgId :: PackageIdentifier
pkgId = PackageDescription -> PackageIdentifier
Cabal.package PackageDescription
pkgDesc
       Map PackageName VersionSplits
nameMap <- Getting
  (Map PackageName VersionSplits)
  CabalInfo
  (Map PackageName VersionSplits)
-> StateT CabalInfo m (Map PackageName VersionSplits)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map PackageName VersionSplits)
  CabalInfo
  (Map PackageName VersionSplits)
Lens' CabalInfo (Map PackageName VersionSplits)
A.debianNameMap
       let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId
           version :: Maybe VersionReq
version = (VersionReq -> Maybe VersionReq
forall a. a -> Maybe a
Just (DebianVersion -> VersionReq
D.EEQ (String -> DebianVersion
forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' (Version -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkgId)))))
       case (Maybe DebBase
nameBase, PackageName -> Map PackageName VersionSplits -> Maybe VersionSplits
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId) Map PackageName VersionSplits
nameMap) of
         (Just DebBase
base, Maybe VersionSplits
_) -> DebBase -> CabalT m DebBase
forall (m :: * -> *) a. Monad m => a -> m a
return DebBase
base
         (Maybe DebBase
Nothing, Maybe VersionSplits
Nothing) -> DebBase -> CabalT m DebBase
forall (m :: * -> *) a. Monad m => a -> m a
return (DebBase -> CabalT m DebBase) -> DebBase -> CabalT m DebBase
forall a b. (a -> b) -> a -> b
$ PackageName -> DebBase
debianBaseName PackageName
pname
         (Maybe DebBase
Nothing, Just VersionSplits
splits) -> DebBase -> CabalT m DebBase
forall (m :: * -> *) a. Monad m => a -> m a
return (DebBase -> CabalT m DebBase) -> DebBase -> CabalT m DebBase
forall a b. (a -> b) -> a -> b
$ VersionSplits -> Maybe VersionReq -> DebBase
doSplits VersionSplits
splits Maybe VersionReq
version

-- | Build a debian package name from a cabal package name and a
-- debian package type.  Unfortunately, this does not enforce the
-- correspondence between the PackageType value and the name type, so
-- it can return nonsense like (SrcPkgName "libghc-debian-dev").
mkPkgName :: PkgName name => CompilerFlavor -> PackageName -> PackageType -> name
mkPkgName :: CompilerFlavor -> PackageName -> PackageType -> name
mkPkgName CompilerFlavor
hc PackageName
pkg PackageType
typ = CompilerFlavor -> PackageType -> DebBase -> name
forall name.
PkgName name =>
CompilerFlavor -> PackageType -> DebBase -> name
mkPkgName' CompilerFlavor
hc PackageType
typ (PackageName -> DebBase
debianBaseName PackageName
pkg)

mkPkgName' :: PkgName name => CompilerFlavor -> PackageType -> DebBase -> name
mkPkgName' :: CompilerFlavor -> PackageType -> DebBase -> name
mkPkgName' CompilerFlavor
hc PackageType
typ (DebBase String
base) =
    String -> name
forall a. PkgName a => String -> a
pkgNameFromString (String -> name) -> String -> name
forall a b. (a -> b) -> a -> b
$
             case PackageType
typ of
                PackageType
Documentation -> String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-doc"
                PackageType
Development -> String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-dev"
                PackageType
Profiling -> String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-prof"
                PackageType
Utilities -> String
base {- ++ case hc of
                                          GHC -> ""
                                          _ -> "-" ++ map toLower (show hc) -}
                PackageType
Exec -> String
base
                PackageType
Source -> String
base
                PackageType
HaskellSource -> String
"haskell-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
base
                PackageType
Cabal -> String
base
    where prefix :: String
prefix = String
"lib" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (CompilerFlavor -> String
forall a. Show a => a -> String
show CompilerFlavor
hc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"

debianBaseName :: PackageName -> DebBase
debianBaseName :: PackageName -> DebBase
debianBaseName PackageName
p =
    String -> DebBase
DebBase ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
fixChar (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower) (PackageName -> String
unPackageName PackageName
p))
    where
      -- Underscore is prohibited in debian package names.
      fixChar :: Char -> Char
      fixChar :: Char -> Char
fixChar Char
'_' = Char
'-'
      fixChar Char
c = Char -> Char
toLower Char
c

-- | Map all versions of Cabal package pname to Debian package dname.
-- Not really a debian package name, but the name of a cabal package
-- that maps to the debian package name we want.  (Should this be a
-- SrcPkgName?)
mapCabal :: Monad m => PackageName -> DebBase -> CabalT m ()
mapCabal :: PackageName -> DebBase -> CabalT m ()
mapCabal PackageName
pname DebBase
dname =
    (Map PackageName VersionSplits
 -> Identity (Map PackageName VersionSplits))
-> CabalInfo -> Identity CabalInfo
Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap ((Map PackageName VersionSplits
  -> Identity (Map PackageName VersionSplits))
 -> CabalInfo -> Identity CabalInfo)
-> (Map PackageName VersionSplits -> Map PackageName VersionSplits)
-> CabalT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Maybe VersionSplits -> Maybe VersionSplits)
-> PackageName
-> Map PackageName VersionSplits
-> Map PackageName VersionSplits
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe VersionSplits -> Maybe VersionSplits
f PackageName
pname
    where
      f :: Maybe VersionSplits -> Maybe VersionSplits
      f :: Maybe VersionSplits -> Maybe VersionSplits
f Maybe VersionSplits
Nothing = VersionSplits -> Maybe VersionSplits
forall a. a -> Maybe a
Just (DebBase -> VersionSplits
makePackage DebBase
dname)
      f (Just VersionSplits
sp) | (DebBase -> Bool) -> [DebBase] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DebBase -> DebBase -> Bool
forall a. Eq a => a -> a -> Bool
== DebBase
dname) (VersionSplits -> DebBase
oldestPackage VersionSplits
sp DebBase -> [DebBase] -> [DebBase]
forall a. a -> [a] -> [a]
: ((Version, DebBase) -> DebBase)
-> [(Version, DebBase)] -> [DebBase]
forall a b. (a -> b) -> [a] -> [b]
map (Version, DebBase) -> DebBase
forall a b. (a, b) -> b
snd (VersionSplits -> [(Version, DebBase)]
splits VersionSplits
sp)) = VersionSplits -> Maybe VersionSplits
forall a. a -> Maybe a
Just VersionSplits
sp
      f (Just VersionSplits
sp) = String -> Maybe VersionSplits
forall a. HasCallStack => String -> a
error (String -> Maybe VersionSplits) -> String -> Maybe VersionSplits
forall a b. (a -> b) -> a -> b
$ String
"mapCabal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
pname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DebBase -> String
forall a. Show a => a -> String
show DebBase
dname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": - already mapped: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionSplits -> String
forall a. Show a => a -> String
show VersionSplits
sp

-- | Map versions less than ver of Cabal Package pname to Debian package ltname
splitCabal :: Monad m => PackageName -> DebBase -> Version -> CabalT m ()
splitCabal :: PackageName -> DebBase -> Version -> CabalT m ()
splitCabal PackageName
pname DebBase
ltname Version
ver =
    (Map PackageName VersionSplits
 -> Identity (Map PackageName VersionSplits))
-> CabalInfo -> Identity CabalInfo
Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap ((Map PackageName VersionSplits
  -> Identity (Map PackageName VersionSplits))
 -> CabalInfo -> Identity CabalInfo)
-> (Map PackageName VersionSplits -> Map PackageName VersionSplits)
-> CabalT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Maybe VersionSplits -> Maybe VersionSplits)
-> PackageName
-> Map PackageName VersionSplits
-> Map PackageName VersionSplits
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe VersionSplits -> Maybe VersionSplits
f PackageName
pname
    where
      f :: Maybe VersionSplits -> Maybe VersionSplits
      f :: Maybe VersionSplits -> Maybe VersionSplits
f Maybe VersionSplits
Nothing = String -> Maybe VersionSplits
forall a. HasCallStack => String -> a
error (String -> Maybe VersionSplits) -> String -> Maybe VersionSplits
forall a b. (a -> b) -> a -> b
$ String
"splitCabal - not mapped: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
pname
      f (Just VersionSplits
sp) = VersionSplits -> Maybe VersionSplits
forall a. a -> Maybe a
Just (Version -> DebBase -> VersionSplits -> VersionSplits
insertSplit Version
ver DebBase
ltname VersionSplits
sp)

-- | Replace any existing mapping of the cabal name 'pname' with the
-- debian name 'dname'.  (Use case: to change the debian package name
-- so it differs from the package provided by ghc.)
remapCabal :: Monad m => PackageName -> DebBase -> CabalT m ()
remapCabal :: PackageName -> DebBase -> CabalT m ()
remapCabal PackageName
pname DebBase
dname = do
  (Map PackageName VersionSplits
 -> Identity (Map PackageName VersionSplits))
-> CabalInfo -> Identity CabalInfo
Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap ((Map PackageName VersionSplits
  -> Identity (Map PackageName VersionSplits))
 -> CabalInfo -> Identity CabalInfo)
-> (Map PackageName VersionSplits -> Map PackageName VersionSplits)
-> CabalT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Maybe VersionSplits -> Maybe VersionSplits)
-> PackageName
-> Map PackageName VersionSplits
-> Map PackageName VersionSplits
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe VersionSplits -> Maybe VersionSplits -> Maybe VersionSplits
forall a b. a -> b -> a
const Maybe VersionSplits
forall a. Maybe a
Nothing) PackageName
pname
  PackageName -> DebBase -> CabalT m ()
forall (m :: * -> *).
Monad m =>
PackageName -> DebBase -> CabalT m ()
mapCabal PackageName
pname DebBase
dname