Relations.hs

{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, PackageImports, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-}
{-# OPTIONS -Wall -fno-warn-orphans #-}

-- |
-- Module      :  Distribution.Package.Debian
-- Copyright   :  David Fox 2008
--
-- Maintainer  :  David Fox <dsf@seereason.com>
-- Stability   :  alpha
-- Portability :  portable
--
-- Explanation: Support for generating Debianization from Cabal data.

-- This software may be used and distributed according to the terms of
-- the GNU General Public License, incorporated herein by reference.

module Distribution.Package.Debian.Relations
    ( allBuildDepends
    , debianDependencies
    , buildDependencies
    , docDependencies
    , cabalDependencies
    , noVersion
    -- , debianRelation
    ) where

import Data.Char (isSpace)
import Data.Either (partitionEithers)
import Data.List
import Data.Logic (Logic(..), Boolean(..), Negatable(..), Combine(..), BinOp(..), PropositionalFormula(..))
import Data.Logic.Types.Propositional (Formula(..))
--import Distribution.Package.Debian.DebianRelations (toFormula, ofFormula)
import Data.Logic.Classes.Propositional (clauseNormalFormAlt')
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set, member, fromList)
import Data.Version (showVersion)
import qualified Debian.Relation as D
import Debian.Version (DebianVersion, prettyDebianVersion)
import Debian.Version.String
import System.IO.Unsafe (unsafePerformIO)
import System.Process (readProcessWithExitCode)
import System.Unix.Process

import Distribution.Simple.Compiler (Compiler(..))
import Distribution.Package (PackageIdentifier(..), PackageName(..), Dependency(..))
import Distribution.PackageDescription (PackageDescription(..),
                                        allBuildInfo, buildTools, pkgconfigDepends,
                                        extraLibs)
import Distribution.Version (Version(..),VersionRange(..))
import Distribution.Package.Debian.Setup (Flags(..))
import Distribution.Package.Debian.Bundled (Bundled, isBundled, PackageType(..), debianName, versionSplits, ghcBuiltIns {-, builtIns, ghc6BuiltIns-})

instance Show DebianVersion where
    show = show . prettyDebianVersion

{-
deriving instance Show D.VersionReq
deriving instance Show D.ArchitectureReq
deriving instance Show D.Relation
-}

cabalDependencies :: PackageDescription -> [Dependency]
cabalDependencies pkgDesc = map unboxDependency $ allBuildDepends pkgDesc

-- |Debian packages don't have per binary package build dependencies,
-- so we just gather them all up here.
allBuildDepends :: PackageDescription -> [Dependency_]
allBuildDepends pkgDesc =
    nub $ map BuildDepends (buildDepends pkgDesc) ++
          concat (map (map BuildTools . buildTools) (allBuildInfo pkgDesc) ++
                  map
                    (map PkgConfigDepends . pkgconfigDepends)
                    (allBuildInfo pkgDesc) ++
                  map (map ExtraLibs . extraLibs) (allBuildInfo pkgDesc))

-- Turn a cabal dependency into a list of debian relations.  If a
-- library is required as a build dependency we need the profiling
-- version, which pulls in the regular version, and we need the
-- documentation so the cross references can be resolved.
debianDependencies :: Flags -> Bundled -> Compiler -> (Flags -> Compiler -> Dependency_ -> D.Relations) -> Dependency_ -> D.Relations
debianDependencies _ bundled compiler _toDebRels dep
  | isBundled [bundled] compiler $ unboxDependency dep = []
debianDependencies flags _ compiler toDebRels dep = toDebRels flags compiler dep

-- The build dependencies for a package include the profiling
-- libraries and the documentation packages, used for creating cross
-- references.
buildDependencies :: Flags -> Compiler -> Dependency_ -> D.Relations
buildDependencies _ compiler (BuildDepends (Dependency name _ranges)) | member name (base compiler) = []
buildDependencies flags _ (BuildDepends (Dependency name ranges)) =
    debianRelations flags Development name ranges ++ debianRelations flags Profiling name ranges
buildDependencies flags _ dep@(ExtraLibs _) =
    concat (map (\ x -> debianRelations flags Extra x AnyVersion) $ adapt flags dep)
buildDependencies flags _ dep =
    concat (map (\ x -> debianRelations flags Extra x ranges) $ adapt flags dep)
    where (Dependency _name ranges) = unboxDependency dep

adapt :: Flags -> Dependency_ -> [PackageName]
adapt flags (PkgConfigDepends (Dependency (PackageName pkg) _)) =
    maybe (aptFile pkg) (\ x -> [PackageName x]) (Map.lookup pkg (execMap flags))
adapt flags (BuildTools (Dependency (PackageName pkg) _)) =
    maybe (aptFile pkg) (\ x -> [PackageName x]) (Map.lookup pkg (execMap flags))
adapt flags (ExtraLibs x) =
    [PackageName  (fromMaybe ("lib" ++ x ++ "-dev") (Map.lookup x (libMap flags)))]
-- adapt _ dep = [name] where  (Dependency name _) = unboxDependency dep
adapt _flags (BuildDepends (Dependency pkg _)) = [pkg]

-- |There are two reasons this may not work, or may work
-- incorrectly: (1) the build environment may be a different
-- distribution than the parent environment (the environment the
-- autobuilder was run from), so the packages in that
-- environment might have different names, and (2) the package
-- we are looking for may not be installed in the parent
-- environment.
aptFile :: String -> [PackageName]
aptFile pkg =
    unsafePerformIO $
          do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] ""
             return $ case ret of
                        (ExitSuccess, out, _) -> [PackageName (takeWhile (not . isSpace) out)]
                        _ -> []
{-
adapt (ExtraLibs "gcrypt") = [PackageName "libgcrypt11-dev"]
-}

-- The documentation dependencies for a package include the documentation
-- package for any libraries which are build dependencies, so we have access
-- to all the cross references.
docDependencies :: Flags -> Compiler -> Dependency_ -> D.Relations
docDependencies
    flags
    compiler
    (BuildDepends (Dependency name ranges))
  = concat
    (map
        (\ x -> debianRelations flags Documentation x ranges)
      $ filter (not . flip member (base compiler)) [name])
docDependencies _ _ _ = []

base :: Compiler -> Set PackageName
base compiler =
    Data.Set.fromList (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -} (_, _, xs) = ghcBuiltIns compiler in map pkgName xs)

{-
instance Show DebianVersion where
  show = show . show . prettyDebianVersion
deriving instance Show D.ArchitectureReq
deriving instance Show D.VersionReq
deriving instance Show D.Relation

deriving instance Show (Formula D.Relation)
deriving instance Show (Combine (Formula D.Relation))
-}

{-
-- |Improper subset function for VersionRange - just covering some simple cases for now.
subset :: VersionRange -> VersionRange -> Bool
subset _ AnyVersion = True
subset (ThisVersion v1) (LaterVersion v2) = v1 > v2
subset (ThisVersion v1) (EarlierVersion v2) = v1 < v2
subset (LaterVersion v1) (LaterVersion v2) = v1 >= v2
subset (EarlierVersion v1) (EarlierVersion v2) = v1 <= v2
subset _ _ = False
-}

-- FIXME: we don't run split
debianRelations :: Flags -> PackageType -> PackageName -> VersionRange -> D.Relations
debianRelations _flags typ name range =
    convert'' . simplify . map Set.toList . Set.toList . clauseNormalFormAlt' . expand $ range
    -- map (map convert) . t4 . simplify . t3 . flatten . clauseNormalForm . t2 . split . t1 . expand $ range
    -- t3 $ debianRelation typ name range
    where
      -- Split up relations where the versionSplits list tells us.
      -- Doesn't handle the package names, only the version numbers
      split :: VersionRange -> VersionRange
      split range' = foldr split' range' versionSplits
      split' (n, v, _, _) range' =
          split'' range'
          where
            split'' x | n /= name = x
            split'' (ThisVersion v') = ThisVersion v'
            split'' AnyVersion = UnionVersionRanges (EarlierVersion v) AnyVersion
            split'' (EarlierVersion version) | v <= version = EarlierVersion v
            split'' (EarlierVersion version) | v > version = UnionVersionRanges (EarlierVersion v) (EarlierVersion version)
            split'' (LaterVersion version) | v <= version = (LaterVersion version)
            split'' (LaterVersion version) | v >= version = UnionVersionRanges (LaterVersion v) (LaterVersion version)
            split'' (UnionVersionRanges range1 range2) = UnionVersionRanges (split'' range1) (split'' range2)
            split'' (IntersectVersionRanges range1 range2) = IntersectVersionRanges (split'' range1) (split'' range2)
            split'' x = error $ "split'' " ++ show x
      convert'' :: [[VersionRange]] -> [[D.Relation]]
      -- Because fromBool True returns AnyVersion, we will get an empty list
      -- in the result where there was an AnyVersion by itself.
      convert'' ([] : xss) = convert'' $ [AnyVersion] : xss
      convert'' (xs : xss) = convert' xs : convert'' xss
      convert'' [] = []

      convert' :: [VersionRange] -> [D.Relation]
      convert' [] = []
      convert' (ThisVersion v1 : LaterVersion v2 : xs) | v1 == v2 = D.Rel (debianName typ name (ThisVersion v1)) (Just (D.GRE (parseDebianVersion (showVersion v1)))) Nothing : convert' xs
      convert' (AnyVersion : EarlierVersion v : xs) = D.Rel (debianName typ name (EarlierVersion v)) (Just (D.SLT (parseDebianVersion (showVersion v)))) Nothing : convert' xs
      convert' (x : xs) = convert x : convert' xs

      convert :: VersionRange -> D.Relation
      convert AnyVersion = D.Rel (debianName typ name AnyVersion) Nothing Nothing
      convert (ThisVersion version) = D.Rel (debianName typ name (ThisVersion version)) (Just (D.EEQ (parseDebianVersion (showVersion version)))) Nothing
      convert (EarlierVersion version) = D.Rel (debianName typ name (EarlierVersion version)) (Just (D.SLT (parseDebianVersion (showVersion version)))) Nothing
      convert (LaterVersion version) = D.Rel (debianName typ name (LaterVersion version)) (Just (D.SGR (parseDebianVersion (showVersion version)))) Nothing
      convert x = error $ "convert'' " ++ show x


      -- This still doesn't work correctly.  But we may be able to build with it.
      simplify :: [[VersionRange]] -> [[VersionRange]]
      simplify xss = simplifyAnds (map simplifyOrs xss)
      -- Try to merge every pair
      simplifyOrs :: [VersionRange] -> [VersionRange]
      simplifyOrs [] = []
      simplifyOrs (x : xs) =
          case partitionEithers (map (mergeOrs x) (map Left (simplifyOrs xs))) of
            -- Nothing to merge with
            ([], []) -> [x]
            -- If x merged with anything re-run with newly merged results
            ([], merged) -> simplifyOrs merged
            -- If x does not merge just return
            (_, _) -> x : xs

      simplifyAnds :: [[VersionRange]] -> [[VersionRange]]
      simplifyAnds [] = []
      simplifyAnds (x : xs) =
          case partitionEithers (map (mergeAnds x) (map Left (simplifyAnds xs))) of
            ([], []) -> [x]
            ([], merged) -> simplifyAnds merged
            (_, _) -> x : xs

-- |Replace ThisVersion with WildcardVersion so we can safely add
-- suffixes to generate debian version numbers.
expand (ThisVersion version) = expand (WildcardVersion version)
expand (WildcardVersion version) =
          (IntersectVersionRanges
           (UnionVersionRanges (ThisVersion version) (LaterVersion version))
           (EarlierVersion (upperBound version)))
-- Some obvious simplifications
expand (UnionVersionRanges range1 range2) | range1 == range2 = expand range1
expand (UnionVersionRanges AnyVersion _) = AnyVersion
expand (UnionVersionRanges _ AnyVersion) = AnyVersion
expand (UnionVersionRanges range1 range2) = UnionVersionRanges (expand range1) (expand range2)
expand (IntersectVersionRanges range1 range2) | range1 == range2 = expand range1
expand (IntersectVersionRanges range1 AnyVersion) = expand range1
expand (IntersectVersionRanges AnyVersion range2) = expand range2
expand (IntersectVersionRanges range1 range2) = IntersectVersionRanges (expand range1) (expand range2)
expand (VersionRangeParens range) = expand range
expand x = x

-- Assumes we are in CNF
flatten :: VersionRange -> [[VersionRange]]
flatten (IntersectVersionRanges a b) = flatten a ++ flatten b
flatten x = [flatten' x]
flatten' :: VersionRange -> [VersionRange]
flatten' (UnionVersionRanges a b) = flatten' a ++ flatten' b
flatten' x = [x]

{-
mergeOrs :: [VersionRange] -> VersionRange
mergeOrs rs = foldr mergeOrs map rs
-}

mergeAnds :: [VersionRange] -> Either [VersionRange] [VersionRange] -> Either [VersionRange] [VersionRange]
mergeAnds [AnyVersion] (Left x) = Right x
mergeAnds x (Left [AnyVersion]) = Right x
mergeAnds x y = y

mergeOrs :: VersionRange -> Either VersionRange VersionRange -> Either VersionRange VersionRange
mergeOrs AnyVersion _ = Right AnyVersion
mergeOrs x (Left y) | x == noVersion = Right x
mergeOrs x (Left y) | y == noVersion = Right y
mergeOrs _ (Left AnyVersion) = Right AnyVersion
mergeOrs (ThisVersion v1) (Left x@(ThisVersion v2)) = if v1 == v2 then Right (ThisVersion v1) else Left x
mergeOrs (ThisVersion v1) (Left x@(EarlierVersion v2)) = if v1 < v2 then Right (EarlierVersion v2) else Left x
mergeOrs (ThisVersion v1) (Left x@(LaterVersion v2)) = if v1 > v2 then Right (LaterVersion v2) else Left x
mergeOrs (ThisVersion v1) (Left x@(EarlierVersion v2)) = if v1 < v2 then Right (EarlierVersion v2) else Left x
mergeOrs (ThisVersion v1) (Left x@(LaterVersion v2)) = if v1 > v2 then Right (LaterVersion v2) else Left x
mergeOrs (EarlierVersion v1) (Left x@(LaterVersion v2)) = if v1 > v2 then Right AnyVersion else Left x
mergeOrs (LaterVersion v2) (Left x@(EarlierVersion v1)) = if v1 > v2 then Right AnyVersion else Left x
mergeOrs (EarlierVersion v1) (Left (EarlierVersion v2)) = Right (EarlierVersion (max v1 v2))
mergeOrs (LaterVersion v1) (Left (LaterVersion v2)) = Right (LaterVersion (min v1 v2))
mergeOrs (EarlierVersion v1) (Left x@(ThisVersion v2)) = if v2 < v1 then Right (EarlierVersion v1) else Left x
mergeOrs (LaterVersion v1) (Left x@(ThisVersion v2)) = if v1 < v2 then Right (LaterVersion v1) else Left x
mergeOrs x y = error $ "merge2 " ++ show x ++ " " ++ show y

data Dependency_
  = BuildDepends Dependency
      | BuildTools Dependency
      | PkgConfigDepends Dependency
      | ExtraLibs String
    deriving (Eq, Show)

unboxDependency :: Dependency_ -> Dependency
unboxDependency (BuildDepends d) = d
unboxDependency (BuildTools d) = d
unboxDependency (PkgConfigDepends d) = d
unboxDependency (ExtraLibs d) = Dependency (PackageName d) AnyVersion

{-
-- | cartesianProduct [[1,2,3], [4,5],[6]] -> [[1,4,6],[1,5,6],[2,4,6],[2,5,6],[3,4,6],[3,5,6]]
cartesianProduct :: [[a]] -> [[a]]
cartesianProduct = sequence
-}

deriving instance Ord VersionRange

instance Logic VersionRange where
    a .|. b = UnionVersionRanges a b

instance Negatable VersionRange where
    (.~.) (VersionRangeParens r) = (.~.) r
    (.~.) AnyVersion = fromBool False
    (.~.) (ThisVersion v) = UnionVersionRanges (EarlierVersion v) (LaterVersion v)
    (.~.) (EarlierVersion v) = UnionVersionRanges (ThisVersion v) (LaterVersion v)
    (.~.) (LaterVersion v) = UnionVersionRanges (EarlierVersion v) (ThisVersion v)
    (.~.) (WildcardVersion v) = (.~.) (IntersectVersionRanges (UnionVersionRanges (ThisVersion v) (LaterVersion v)) (EarlierVersion (upperBound v)))
    -- These three are not necessary, but may keep thing neater.
    (.~.) (UnionVersionRanges (EarlierVersion v1) (LaterVersion v2)) | v1 == v2 = ThisVersion v1
    (.~.) (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 = EarlierVersion v1
    (.~.) (UnionVersionRanges (EarlierVersion v1) (ThisVersion v2)) | v1 == v2 = LaterVersion v1
{-  (.~.) (IntersectVersionRanges (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) (EarlierVersion v3))
           | v1 == v2 && v3 == upperBound v1 = WildcardVersion v1 -}
    -- Inversion of & and |
    (.~.) (UnionVersionRanges r1 r2) = IntersectVersionRanges ((.~.) r1) ((.~.) r2)
    (.~.) (IntersectVersionRanges r1 r2) = UnionVersionRanges ((.~.) r1) ((.~.) r2)
    negated _ = False

-- FIXME: the noVersion value, if present in the final set of
-- dependencies, leads to empty version numbers.  We need a better way
-- to simplify the relations than the simplify function in
-- debianRelations.
instance Boolean VersionRange where
    fromBool True = AnyVersion
    fromBool False = noVersion

instance PropositionalFormula VersionRange VersionRange where
    atomic x = x
    foldPropositional c _ (IntersectVersionRanges r1 r2) = c (BinOp r1 (:&:) r2)
    foldPropositional c _ (UnionVersionRanges r1 r2) = c (BinOp r1 (:|:) r2)
    foldPropositional _ a x = a x

noVersion = ThisVersion (Version {versionBranch = [], versionTags = []})

{-
    asBool f =
        foldF0 (const Nothing) (\ x -> case x of
                                         AnyVersion -> Just True
                                         ThisVersion (Version {versionBranch = [], versionTags = []}) -> Just False
                                         _ -> Nothing) f
-}

upperBound :: Version -> Version
upperBound v =
    v { versionBranch = bump (versionBranch v) }
    where bump = reverse . (zipWith (+) (1:(repeat 0))) . reverse