-- | 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
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
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 :: forall (m :: * -> *) name.
(Monad m, PkgName name) =>
PackageType -> CompilerFlavor -> CabalT m name
debianName PackageType
typ CompilerFlavor
hc =
    do String
base <-
           case (PackageType
typ, CompilerFlavor
hc) of
             (PackageType
Utilities, CompilerFlavor
GHC) -> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' CabalInfo DebInfo
debInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DebInfo (Maybe String)
utilsPackageNameBase) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((\ String
base -> String
"haskell-" forall a. [a] -> [a] -> [a]
++ String
base forall a. [a] -> [a] -> [a]
++ String
"-utils") forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebBase -> String
unDebBase) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase) forall (m :: * -> *) a. Monad m => a -> m a
return
             (PackageType
Utilities, CompilerFlavor
_) -> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' CabalInfo DebInfo
debInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DebInfo (Maybe String)
utilsPackageNameBase) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((\ String
base -> String
base forall a. [a] -> [a] -> [a]
++ String
"-utils") forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebBase -> String
unDebBase) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase) forall (m :: * -> *) a. Monad m => a -> m a
return
             (PackageType, CompilerFlavor)
_ -> DebBase -> String
unDebBase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *). Monad m => CabalT m DebBase
debianNameBase =
    do Maybe DebBase
nameBase <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' CabalInfo DebInfo
debInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DebInfo (Maybe DebBase)
D.overrideDebianNameBase)
       PackageDescription
pkgDesc <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CabalInfo PackageDescription
packageDescription
       let pkgId :: PackageIdentifier
pkgId = PackageDescription -> PackageIdentifier
Cabal.package PackageDescription
pkgDesc
       Map PackageName VersionSplits
nameMap <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CabalInfo (Map PackageName VersionSplits)
A.debianNameMap
       let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId
           version :: Maybe VersionReq
version = (forall a. a -> Maybe a
Just (DebianVersion -> VersionReq
D.EEQ (forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' (forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkgId)))))
       case (Maybe DebBase
nameBase, 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return DebBase
base
         (Maybe DebBase
Nothing, Maybe VersionSplits
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PackageName -> DebBase
debianBaseName PackageName
pname
         (Maybe DebBase
Nothing, Just VersionSplits
splits) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall name.
PkgName name =>
CompilerFlavor -> PackageName -> PackageType -> name
mkPkgName CompilerFlavor
hc PackageName
pkg PackageType
typ = 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' :: forall name.
PkgName name =>
CompilerFlavor -> PackageType -> DebBase -> name
mkPkgName' CompilerFlavor
hc PackageType
typ (DebBase String
base) =
    forall a. PkgName a => String -> a
pkgNameFromString forall a b. (a -> b) -> a -> b
$
             case PackageType
typ of
                PackageType
Documentation -> String
prefix forall a. [a] -> [a] -> [a]
++ String
base forall a. [a] -> [a] -> [a]
++ String
"-doc"
                PackageType
Development -> String
prefix forall a. [a] -> [a] -> [a]
++ String
base forall a. [a] -> [a] -> [a]
++ String
"-dev"
                PackageType
Profiling -> String
prefix forall a. [a] -> [a] -> [a]
++ String
base 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-" forall a. [a] -> [a] -> [a]
++ String
base
                PackageType
Cabal -> String
base
    where prefix :: String
prefix = String
"lib" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall a. Show a => a -> String
show CompilerFlavor
hc) forall a. [a] -> [a] -> [a]
++ String
"-"

debianBaseName :: PackageName -> DebBase
debianBaseName :: PackageName -> DebBase
debianBaseName PackageName
p =
    String -> DebBase
DebBase (forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
fixChar 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 :: forall (m :: * -> *).
Monad m =>
PackageName -> DebBase -> CabalT m ()
mapCabal PackageName
pname DebBase
dname =
    Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= 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 = forall a. a -> Maybe a
Just (DebBase -> VersionSplits
makePackage DebBase
dname)
      f (Just VersionSplits
sp) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== DebBase
dname) (VersionSplits -> DebBase
oldestPackage VersionSplits
sp forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (VersionSplits -> [(Version, DebBase)]
splits VersionSplits
sp)) = forall a. a -> Maybe a
Just VersionSplits
sp
      f (Just VersionSplits
sp) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mapCabal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PackageName
pname forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DebBase
dname forall a. [a] -> [a] -> [a]
++ String
": - already mapped: " forall a. [a] -> [a] -> [a]
++ 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 :: forall (m :: * -> *).
Monad m =>
PackageName -> DebBase -> Version -> CabalT m ()
splitCabal PackageName
pname DebBase
ltname Version
ver =
    Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= 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 = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"splitCabal - not mapped: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PackageName
pname
      f (Just VersionSplits
sp) = 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 :: forall (m :: * -> *).
Monad m =>
PackageName -> DebBase -> CabalT m ()
remapCabal PackageName
pname DebBase
dname = do
  Lens' CabalInfo (Map PackageName VersionSplits)
debianNameMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) PackageName
pname
  forall (m :: * -> *).
Monad m =>
PackageName -> DebBase -> CabalT m ()
mapCabal PackageName
pname DebBase
dname