cabal-debian 3.0.7 → 3.4

raw patch · 32 files changed

+769/−812 lines, 32 filesdep ~Cabaldep ~basedep ~debiansetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, base, debian

API changes (from Hackage documentation)

Files

• Setup.hs +1/−1
• cabal-debian.cabal +38/−13
• debian/Debianize.hs +23/−23
• debian/changelog +83/−0
• src/CabalDebian.hs +18/−1
• src/Data/Algorithm/Diff/Context.hs +6/−0
• src/Data/Algorithm/Diff/Pretty.hs +2/−0
• src/Debian/Debianize.hs +0/−2
• src/Debian/Debianize/Atoms.hs +84/−36
• src/Debian/Debianize/Bundled.hs +60/−1
• src/Debian/Debianize/ControlFile.hs +4/−4
• src/Debian/Debianize/Debianize.hs +39/−33
• src/Debian/Debianize/Dependencies.hs +37/−60
• src/Debian/Debianize/Details.hs +45/−0
• src/Debian/Debianize/Files.hs +5/−5
• src/Debian/Debianize/Finalize.hs +8/−8
• src/Debian/Debianize/Generic.hs +0/−108
• src/Debian/Debianize/Goodies.hs +21/−56
• src/Debian/Debianize/Input.hs +32/−52
• src/Debian/Debianize/Interspersed.hs +1/−1
• src/Debian/Debianize/Options.hs +7/−3
• src/Debian/Debianize/SubstVars.hs +2/−2
• src/Debian/Debianize/Tests.hs +78/−56
• src/Debian/Debianize/Types.hs +4/−10
• src/Debian/Debianize/Types/VersionSplits.hs +100/−0
• src/Debian/Debianize/Utility.hs +6/−1
• src/Debian/Debianize/VersionSplits.hs +31/−0
• src/Debian/Orphans.hs +1/−15
• src/Debian/Policy.hs +32/−8
• src/Distribution/Version/Invert.hs +1/−0
• src/Tests.hs +0/−7
• src/Triplets.hs +0/−306

@@ -12,7 +12,7 @@                  case buildDir lbi of                    "dist-ghc/build" -> return ()                    _ -> runTestScript lbi-       , runTests = \ _ _ _ lbi -> runTestScript lbi+       -- , runTests = \ _ _ _ lbi -> runTestScript lbi        }  runTestScript lbi =

@@ -1,5 +1,5 @@ Name:           cabal-debian-Version:        3.0.7+Version:        3.4 License:        BSD3 License-File:   debian/copyright Author:         David Fox <dsf@seereason.com>@@ -17,6 +17,11 @@  file.  If apt-file is installed it will use it to discover what is the  debian package name of a C library. +Flag tests+  Description: enable the unit test executable (disabled by default because it has a lot of wacky dependencies.)+  Default: False+  Manual: True+ Source-Repository head   type: darcs   location: http://src.seereason.com/debian-tools@@ -32,7 +37,7 @@    Cabal >= 1.9,    containers,    data-lens,-   debian >= 3.70,+   debian >= 3.71,    Diff,    directory,    filepath,@@ -58,9 +63,9 @@    Debian.Debianize.ControlFile    Debian.Debianize.Debianize    Debian.Debianize.Dependencies+   Debian.Debianize.Details    Debian.Debianize.Files    Debian.Debianize.Finalize-   Debian.Debianize.Generic    Debian.Debianize.Goodies    Debian.Debianize.Interspersed    Debian.Debianize.Input@@ -68,25 +73,45 @@    Debian.Debianize.SubstVars    Debian.Debianize.Tests    Debian.Debianize.Types+   Debian.Debianize.Types.VersionSplits    Debian.Debianize.Utility+   Debian.Debianize.VersionSplits    Debian.Orphans    Debian.Policy    Distribution.Version.Invert-   Triplets  Executable cabal-debian  Main-is: src/CabalDebian.hs  ghc-options: -threaded -Wall -O2  Build-Depends:    base,+   Cabal,    cabal-debian,-   containers+   containers,+   data-lens -Executable cabal-debian-tests- Main-Is: src/Tests.hs- GHC-Options: -Wall -O2 -threaded -rtsopts- Build-Depends:-   base,-   cabal-debian,-   Diff,-   HUnit+-- Executable cabal-debian-tests+--  Main-Is: src/Tests.hs+--  GHC-Options: -Wall -O2 -threaded -rtsopts+--  Build-Depends:+--    ansi-wl-pprint,+--    base,+--    Cabal,+--    cabal-debian,+--    containers,+--    data-lens,+--    debian,+--    Diff,+--    directory,+--    filepath,+--    hsemail,+--    HUnit,+--    mtl,+--    parsec,+--    process,+--    pureMD5,+--    regex-tdfa,+--    syb,+--    text,+--    unix,+--    utf8-string

@@ -6,25 +6,34 @@ import Data.Text as Text (intercalate) import Debian.Debianize as Atoms import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))+import Debian.Debianize.Details (seereasonDefaultAtoms) import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT)) import Debian.Version (parseDebianVersion) import Prelude hiding (log)  main :: IO () main =-    do log <- inputChangeLog "debian"-       new <- debianization "."-               (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) $-                setL changelog (Just log) $-                setL compat (Just 7) $-                setL standards (Just (StandardsVersion 3 9 3 Nothing)) $-                setL sourceFormat (Just Native3) $-                -- modL extraDevDeps (Set.insert (BinPkgName "debian-policy")) $-                setL utilsPackageName (Just (BinPkgName "cabal-debian")) $-                modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") Nothing Nothing))) $-                modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) $-                modL Atoms.depends (Map.insertWith union (BinPkgName "libghc-cabal-debian-dev") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) $-                modL conflicts (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) $+    do log <- inputChangeLog (Top ".")+       new <- debianization (Top ".") (return . customize . setL changelog (Just log)) seereasonDefaultAtoms+       old <- inputDebianization (Top ".")+       case compareDebianization old (copyFirstLogEntry old new) of+         "" -> return ()+         s -> error $ "Debianization mismatch:\n" ++ s+       -- This would overwrite the existing debianization rather than+       -- just make sure it matches:+       -- writeDebianization "." new+    where+      customize =+               (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) .+                setL compat (Just 7) .+                setL standards (Just (StandardsVersion 3 9 3 Nothing)) .+                setL sourceFormat (Just Native3) .+                -- modL extraDevDeps (Set.insert (BinPkgName "debian-policy")) .+                setL utilsPackageName (Just (BinPkgName "cabal-debian")) .+                modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") Nothing Nothing))) .+                modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) .+                modL Atoms.depends (Map.insertWith union (BinPkgName "libghc-cabal-debian-dev") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) .+                modL conflicts (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) .                 modL description (Map.insertWith (error "test7") (BinPkgName "cabal-debian")                                         (Text.intercalate "\n"                                          [ "Create a debianization for a cabal package"@@ -33,16 +42,7 @@                                          , " debian package name of a C library."                                          , " ."                                          , "  Author: David Fox <dsf@seereason.com>"-                                         , "  Upstream-Maintainer: David Fox <dsf@seereason.com>" ])) $-                defaultAtoms)-       old <- inputDebianization "."-       case compareDebianization old (copyFirstLogEntry old new) of-         "" -> return ()-         s -> error $ "Debianization mismatch:\n" ++ s--       -- This would overwrite the existing debianization rather than-       -- just make sure it matches:-       -- writeDebianization "." new+                                         , "  Upstream-Maintainer: David Fox <dsf@seereason.com>" ])))  -- | This copies the first log entry of deb1 into deb2.  Because the -- debianization process updates that log entry, we need to undo that

@@ -1,3 +1,86 @@+haskell-cabal-debian (3.4) unstable; urgency=low++  * Add support for modifying the Provides and Replaces fields.++ -- David Fox <dsf@seereason.com>  Sun, 09 Jun 2013 14:18:39 -0700++haskell-cabal-debian (3.3.2) unstable; urgency=low++  * Changes for debian-3.71++ -- David Fox <dsf@seereason.com>  Sun, 14 Apr 2013 13:32:04 -0700++haskell-cabal-debian (3.3.1) unstable; urgency=low++  * Don't fail during dry run if the existing debianization has no+    copyright file.++ -- David Fox <dsf@seereason.com>  Wed, 13 Mar 2013 10:00:25 -0700++haskell-cabal-debian (3.3) unstable; urgency=low++  * Add Debian.Debianize.Details, with default Atoms values for Debian and+    SeeReason.++ -- David Fox <dsf@seereason.com>  Mon, 11 Mar 2013 11:44:10 -0700++haskell-cabal-debian (3.2.5) unstable; urgency=low++  * Add move the VersionSplits type into a module, and fix the code that+    splits the mapping of cabal to debian names over a version range.++ -- David Fox <dsf@seereason.com>  Tue, 05 Mar 2013 05:17:03 -0800++haskell-cabal-debian (3.2.4) unstable; urgency=low++  * Fix long standing bug in Debian.Debianize.Interspersed.foldTriples.++ -- David Fox <dsf@seereason.com>  Sun, 03 Mar 2013 09:45:14 -0800++haskell-cabal-debian (3.2.3) unstable; urgency=low++  * Clean up mapping from cabal names to debian names.++ -- David Fox <dsf@seereason.com>  Sat, 02 Mar 2013 07:36:16 -0800++haskell-cabal-debian (3.2.2) unstable; urgency=low++  * Remove unused Debian.Debianize.Generic and Triplets modules.++ -- David Fox <dsf@seereason.com>  Fri, 01 Mar 2013 11:14:33 -0800++haskell-cabal-debian (3.2.1) unstable; urgency=low++  * Do not add the options +RTS -IO -RTS to the server options, this+    is a security risk.  Instead, server executables should built with+    -with-rtsopts=-IO.++ -- David Fox <dsf@seereason.com>  Thu, 28 Feb 2013 09:02:39 -0800++haskell-cabal-debian (3.2) unstable; urgency=low++  * Strip executables when installing (well, at least some.  There+    may be more work to do here.)+  * Change the build dependency type from BinPkgName to Relation, so we+    can specify version dependencies (though as yet not or relations.)++ -- David Fox <dsf@seereason.com>  Tue, 26 Feb 2013 07:17:30 -0800++haskell-cabal-debian (3.1.1) unstable; urgency=low++  * Fix the code in the init file that checks for and sources a+    file in /etc/default.++ -- David Fox <dsf@seereason.com>  Mon, 25 Feb 2013 14:46:02 -0800++haskell-cabal-debian (3.1) unstable; urgency=low++  * Create a Top type to represent the top directory of a debianization+  * Change the signature of Debian.Debianize.debianization so it notices+    command line arguments and environment arguments.++ -- David Fox <dsf@seereason.com>  Fri, 22 Feb 2013 13:28:30 -0800+ haskell-cabal-debian (3.0.7) unstable; urgency=low    * Fix to copyright/license code

@@ -5,7 +5,24 @@ -- function directly, many sophisticated configuration options cannot -- be accessed using the command line interface. +import Data.Lens.Lazy (setL)+import Data.Map as Map (fromList)+import Data.Monoid (mempty)+import Data.Version (Version(Version))+import Debian.Debianize.Atoms (Atoms, epochMap) import Debian.Debianize.Debianize (cabalDebian)+import Debian.Debianize.VersionSplits (mapCabal, splitCabal)+import Distribution.Package (PackageName(PackageName))  main :: IO ()-main = cabalDebian+main = cabalDebian defaultAtoms++defaultAtoms :: Atoms+defaultAtoms =+    setL epochMap (fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) .+    splitCabal (PackageName "parsec") "parsec2" (Version [3] []) .+    mapCabal (PackageName "parsec") "parsec3" .+    splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) .+    mapCabal (PackageName "QuickCheck") "quickcheck2" .+    mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $+    mempty

@@ -48,7 +48,13 @@ groups f xs =     filter (/= []) $ reverse (groups' [[]] xs)     where+      -- Predicate satisfied, add x to the current group r and recurse with y at head       groups' (r : rs) (x : y : xs') | f x y = groups' ((x : r) : rs) (y : xs')+      -- Predicate not satisfied, add x to current group and start a new group containing y       groups' (r : rs) (x : y : xs') = groups' ([y] : reverse (x : r) : rs) xs'+      -- Last element, add it to the current group       groups' (r : rs) [y] = reverse (y : r) : rs+      -- Nothing left, return result       groups' rs [] = rs+      -- This won't happen, groups' is always called with a non-empty list in the first argument+      groups' [] (_ : _) = error "groups"

@@ -6,6 +6,8 @@ import Data.Monoid (mconcat, (<>)) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), Doc, text, empty) +-- | Format the output of 'contextDiff' to look approximately like the+-- output of the unix diff command. prettyDiff :: (Pretty a, Pretty b, Pretty c) => a -> b -> [[Diff [c]]] -> Doc prettyDiff _ _ [] = empty prettyDiff old new hunks =

@@ -53,7 +53,6 @@     , module Debian.Debianize.Dependencies     , module Debian.Debianize.Files     , module Debian.Debianize.Finalize-    , module Debian.Debianize.Generic     , module Debian.Debianize.Goodies     , module Debian.Debianize.Input     , module Debian.Debianize.Interspersed@@ -71,7 +70,6 @@ import Debian.Debianize.Dependencies import Debian.Debianize.Files import Debian.Debianize.Finalize-import Debian.Debianize.Generic import Debian.Debianize.Goodies import Debian.Debianize.Input import Debian.Debianize.Interspersed

@@ -18,7 +18,7 @@     , execMap     , cabalFlagAssignments     -- * Global debian info-    , versionSplits+    , debianNameMap     , epochMap     -- * High level information about the debianization     , description@@ -48,6 +48,8 @@     , buildDepsIndep     , depends     , conflicts+    , replaces+    , provides     , extraDevDeps     -- * Debianization files and file fragments     , rulesHead@@ -86,7 +88,8 @@ import Data.Version (Version, showVersion) import Debian.Changes (ChangeLog) import Debian.Debianize.ControlFile (SourceDebDescription(standardsVersion), newSourceDebDescription)-import Debian.Debianize.Types (PackageInfo(..), Site(..), Server(..), InstallFile(..), VersionSplits(..), DebAction(..))+import Debian.Debianize.Types (PackageInfo(..), Site(..), Server(..), InstallFile(..), DebAction(..))+import Debian.Debianize.Types.VersionSplits (VersionSplits) import Debian.Orphans () import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion) import Debian.Relation (SrcPkgName, BinPkgName, Relation(..))@@ -150,8 +153,6 @@     | DebChangeLog ChangeLog			  -- ^ The changelog, first entry contains the source package name and version     | DebLogComments [[Text]]			  -- ^ Each element is a comment to be added to the changelog, where the                                                   -- element's text elements are the lines of the comment.-    | SourcePackageName SrcPkgName                -- ^ Name to give to debian source package.  If not supplied name is constructed-                                                  -- from the cabal package name.     | DHMaintainer NameAddr			  -- ^ Value for the maintainer field in the control file.  Note that                                                   -- the cabal maintainer field can have multiple addresses, but debian                                                   -- only one.  If this is not explicitly set, it is obtained from the@@ -173,11 +174,16 @@                                                   -- version 0.3.0.0-1build3, we need to specify                                                   -- debVersion="0.3.0.0-1build3" or the version we produce will                                                   -- look older than the one already available upstream.-    | DebVersionSplits [VersionSplits]		  -- ^ Instances where the debian package name is different (for-                                                  -- some range of version numbers) from the default constructed-                                                  -- by mkPkgName.-    | BuildDep BinPkgName			  -- ^ Add a build dependency (FIXME: should be a Rel, or an OrRelation, not a BinPkgName)-    | BuildDepIndep BinPkgName			  -- ^ Add an arch independent build dependency+    | DebianNameMap (Map PackageName VersionSplits)+						  -- ^ Mapping from cabal package name and version to debian source+                                                  -- package name.  This allows different ranges of cabal versions to+                                                  -- map to different debian source package names.+    | SourcePackageName SrcPkgName                -- ^ Name to give to the debian source package.  If not supplied+                                                  -- the name is constructed from the cabal package name.  Note that+                                                  -- DebianNameMap could encode this information if we already knew+                                                  -- the cabal package name, but we can't assume that.+    | BuildDep Relation				  -- ^ Add a build dependency+    | BuildDepIndep Relation			  -- ^ Add an arch independent build dependency     | MissingDependency BinPkgName		  -- ^ Lets cabal-debian know that a package it might expect to exist                                                   -- actually does not, so omit all uses in resulting debianization.     | ExtraLibMapping String BinPkgName		  -- ^ Map a cabal Extra-Library name to a debian binary package name,@@ -224,7 +230,9 @@     | DHBackups String                            -- ^ Configure the executable to do incremental backups     | Depends Relation				  -- ^ Says that the debian package should have this relation in Depends     | Conflicts Relation			  -- ^ Says that the debian package should have this relation in Conflicts-    | DevDepends BinPkgName			  -- ^ Limited version of Depends, put a dependency on the dev library package.  The only+    | Provides Relation				  -- ^ Says that the debian package should have this relation in Provides+    | Replaces Relation				  -- ^ Says that the debian package should have this relation in Replaces+    | DevDepends Relation			  -- ^ Limited version of Depends, put a dependency on the dev library package.  The only                                                   -- reason to use this is because we don't yet know the name of the dev library package.     deriving (Eq, Ord, Show, Typeable) @@ -277,7 +285,8 @@ dryRun :: Lens Atoms Bool dryRun = lens (\ a -> dryRun_ (getL flags a)) (\ b a -> modL flags (\ x -> x {dryRun_ = b}) a) --- | Make sure the version number and package names of the generated debianization match the+-- | Make sure the version number and package names of the supplied+-- and generated debianizations match. validate :: Lens Atoms Bool validate = lens (\ a -> validate_ (getL flags a)) (\ b a -> modL flags (\ x -> x {validate_ = b}) a) @@ -426,16 +435,16 @@ -- | Map from cabal version number ranges to debian package names.  This is a -- result of the fact that only one version of a debian package can be -- installed at a given time, while multiple versions of a cabal packages can.-versionSplits :: Lens Atoms [VersionSplits]-versionSplits = lens g s+debianNameMap :: Lens Atoms (Map PackageName VersionSplits)+debianNameMap = lens g s     where-      g atoms = foldAtoms from [] atoms+      g atoms = foldAtoms from mempty atoms           where-            from Source (DebVersionSplits xs') xs = xs ++ xs'-            from _ _ xs = xs-      s x atoms = insertAtom Source (DebVersionSplits x) (deleteAtoms p atoms)+            from Source (DebianNameMap mp) _ = mp+            from _ _ mp = mp+      s x atoms = insertAtom Source (DebianNameMap x) (deleteAtoms p atoms)           where-            p Source (DebVersionSplits _) = True+            p Source (DebianNameMap _) = True             p _ _ = False  -- | Map of Debian epoch numbers assigned to cabal packages.@@ -470,7 +479,7 @@     where       g atoms = foldAtoms from Map.empty atoms           where-            from (Binary b) (DHExecutable f) x = Map.insertWith (\ a b -> error $ "executable: " ++ show (a, b)) b f x+            from (Binary b) (DHExecutable f) x = Map.insertWith (\ k a -> error $ "executable: " ++ show (k, a)) b f x             from _ _ x = x       s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHExecutable y) atoms') (deleteAtoms p atoms) x           where@@ -483,7 +492,7 @@     where       g atoms = foldAtoms from Map.empty atoms           where-            from (Binary b) (DHServer s) x = Map.insertWith (error "server") b s x+            from (Binary b) (DHServer s') x = Map.insertWith (error "server") b s' x             from _ _ x = x       s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHServer y) atoms') (deleteAtoms p atoms) x           where@@ -496,7 +505,7 @@     where       g atoms = foldAtoms from Map.empty atoms           where-            from (Binary b) (DHWebsite s) x = Map.insertWith (error "website") b s x+            from (Binary b) (DHWebsite s') x = Map.insertWith (error "website") b s' x             from _ _ x = x       s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHWebsite y) atoms') (deleteAtoms p atoms) x           where@@ -509,7 +518,7 @@     where       g atoms = foldAtoms from Map.empty atoms           where-            from (Binary b) (DHBackups s) x = Map.insertWith (error "backups") b s x+            from (Binary b) (DHBackups s') x = Map.insertWith (error "backups") b s' x             from _ _ x = x       s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHBackups y) atoms') (deleteAtoms p atoms) x           where@@ -737,7 +746,7 @@           where             from (Binary b) (DHPriority p) x = Map.insertWith (error "priorities") b p x             from _ _ x = x-      s x atoms = Map.foldWithKey (\ b p atoms'-> insertAtom (Binary b) (DHPriority p) atoms') (deleteAtoms p atoms) x+      s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHPriority p') atoms') (deleteAtoms p atoms) x           where             p (Binary _) (DHPriority _) = True             p _ _ = False@@ -764,20 +773,22 @@           where             from (Binary b) (DHSection p) x = Map.insertWith (error "sections") b p x             from _ _ x = x-      s x atoms = Map.foldWithKey (\ b p atoms'-> insertAtom (Binary b) (DHSection p) atoms') (deleteAtoms p atoms) x+      s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHSection p') atoms') (deleteAtoms p atoms) x           where             p (Binary _) (DHSection _) = True             p _ _ = False  -- * Debian dependency info --- | Build dependencies-buildDeps :: Lens Atoms (Set BinPkgName)+-- | Build dependencies.  FIXME: This should be a Set (Set Relation)+-- so we can build or relations, right now we just assume that each+-- Relation is a singleton set.+buildDeps :: Lens Atoms (Set Relation) buildDeps = lens g s     where       g atoms = foldAtoms from Set.empty atoms           where-            from Source (BuildDep d) x = Set.insert d x+            from Source (BuildDep r) x = Set.insert r x             from _ _ x = x       s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDep d) atoms') (deleteAtoms p atoms) x           where@@ -785,14 +796,14 @@             p _ _ = False  -- | Architecture independent-buildDepsIndep :: Lens Atoms (Set BinPkgName)+buildDepsIndep :: Lens Atoms (Set Relation) buildDepsIndep = lens g s     where       g atoms = foldAtoms from Set.empty atoms           where-            from Source (BuildDepIndep d) x = Set.insert d x+            from Source (BuildDepIndep r) x = Set.insert r x             from _ _ x = x-      s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) x+      s r atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) r           where             p Source (BuildDepIndep _) = True             p _ _ = False@@ -825,11 +836,39 @@             p (Binary _) (Conflicts _) = True             p _ _ = False +-- | Map of extra install replaces for the package's binary debs.+-- We should support all the other dependency fields - provides, replaces, etc.+replaces :: Lens Atoms (Map BinPkgName (Set Relation))+replaces = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (Replaces rel) x = Map.insertWith union b (singleton rel) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Replaces rel) atoms'') atoms' rels) (deleteAtoms p atoms) x+          where+            p (Binary _) (Replaces _) = True+            p _ _ = False++-- | Map of extra install provides for the package's binary debs.+-- We should support all the other dependency fields - provides, replaces, etc.+provides :: Lens Atoms (Map BinPkgName (Set Relation))+provides = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (Provides rel) x = Map.insertWith union b (singleton rel) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Provides rel) atoms'') atoms' rels) (deleteAtoms p atoms) x+          where+            p (Binary _) (Provides _) = True+            p _ _ = False+ -- | Extra install dependencies for the devel library.  Redundant -- with depends, but kept for backwards compatibility.  Also, I -- think maybe this is or was needed because it can be set before -- the exact name of the library package is known.-extraDevDeps :: Lens Atoms (Set BinPkgName)+extraDevDeps :: Lens Atoms (Set Relation) extraDevDeps = lens g s     where       g atoms = foldAtoms from Set.empty atoms@@ -1011,6 +1050,8 @@ -- | The @Standards-Version@ field of the @debian/control@ file standards :: Lens Atoms (Maybe StandardsVersion) standards = lens (\ a -> standardsVersion (getL control a)) (\ b a -> modL control (\ x -> x {standardsVersion = b}) a)++-- | Add a stanza to the binary package's logrotate script. logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text)) logrotateStanza = lens g s     where@@ -1022,6 +1063,8 @@           where             p (Binary _) (DHLogrotateStanza _) = True             p _ _ = False++-- | Add entries to a binary deb's debian/foo.links file. link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) link = lens g s     where@@ -1034,7 +1077,8 @@             p (Binary _) (DHLink _ _) = True             p _ _ = False --- | Install files into directories+-- | Install files into directories by adding entries to the binary+-- deb's debian/foo.install file. install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) install = lens g s     where@@ -1047,7 +1091,7 @@             p (Binary _) (DHInstall _ _) = True             p _ _ = False --- | Rename and install files+-- | Rename and install files.  This is done by adding rules to debian/rules. installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) installTo = lens g s     where@@ -1060,7 +1104,9 @@             p (Binary _) (DHInstallTo _ _) = True             p _ _ = False --- | Install files into the package data directory+-- | Install files into the a binary deb's data directory,+-- /usr/share/packagename-version.  This expands to either an install+-- or an installTo. installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) installData = lens g s     where@@ -1073,7 +1119,9 @@             p (Binary _) (DHInstallData _ _) = True             p _ _ = False --- | Create a file in the deb with the given text+-- | Create a file in the binary deb with the given text.  This is done by+-- writing the file into the cabalInstall directory and adding an entry+-- to the binary deb's .install file. file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text))) file = lens g s     where@@ -1086,7 +1134,7 @@             p (Binary _) (DHFile _ _) = True             p _ _ = False --- | Install a cabal executable+-- | Install a cabal executable into a binary deb. installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) installCabalExec = lens g s     where

@@ -30,7 +30,9 @@ ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) =     case Map.lookup compilerVersion              (Map.fromList (map (\ (cmp, ver, lst) -> (ver, (cmp, ver, lst)))-                            [ (GHC, Version [7,6,1] [], ghc761BuiltIns)+                            [ (GHC, Version [7,6,3] [], ghc763BuiltIns)+                            , (GHC, Version [7,6,2] [], ghc762BuiltIns)+                            , (GHC, Version [7,6,1] [], ghc761BuiltIns)                             , (GHC, Version [7,6,1,20121207] [], ghc761BuiltIns)                             , (GHC, Version [7,4,1] [], ghc741BuiltIns)                             , (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns)@@ -59,6 +61,63 @@  v :: String -> [Int] -> PackageIdentifier v n x = PackageIdentifier (PackageName n) (Version x [])++ghc763BuiltIns :: [PackageIdentifier]+ghc763BuiltIns = [+    v "array" [0,4,0,1],+    v "base" [4,6,0,1],+    v "binary" [0,5,1,1],+    v "bin-package-db" [0,0,0,0],+    v "bytestring" [0,10,0,2],+    v "Cabal" [1,16,0],+    v "containers" [0,5,0,0],+    v "deepseq" [1,3,0,1],+    v "directory" [1,2,0,1],+    v "filepath" [1,3,0,1],+    v "ghc" [7,6,3],+    v "ghc-prim" [0,3,0,0],+    v "haskell2010" [1,1,1,0],+    v "haskell98" [2,0,0,2],+    v "hoopl" [3,9,0,0],+    v "hpc" [0,6,0,0],+    v "integer-gmp" [0,5,0,0],+    v "old-locale" [1,0,0,5],+    v "old-time" [1,1,0,1],+    v "pretty" [1,1,1,0],+    v "process" [1,1,0,2],+    v "template-haskell" [2,8,0,0],+    v "time" [1,4,0,1],+    v "unix" [2,6,0,1]+    ]++-- Removed: rts, extensible-exceptions+ghc762BuiltIns :: [PackageIdentifier]+ghc762BuiltIns = [+    v "array" [0,4,0,1],+    v "base" [4,6,0,1],+    v "binary" [0,5,1,1],+    v "bin-package-db" [0,0,0,0],+    v "bytestring" [0,10,0,2],+    v "Cabal" [1,16,0],+    v "containers" [0,5,0,0],+    v "deepseq" [1,3,0,1],+    v "directory" [1,2,0,1],+    v "filepath" [1,3,0,1],+    v "ghc" [7,6,2],+    v "ghc-prim" [0,3,0,0],+    v "haskell2010" [1,1,1,0],+    v "haskell98" [2,0,0,2],+    v "hoopl" [3,9,0,0],+    v "hpc" [0,6,0,0],+    v "integer-gmp" [0,5,0,0],+    v "old-locale" [1,0,0,5],+    v "old-time" [1,1,0,1],+    v "pretty" [1,1,1,0],+    v "process" [1,1,0,2],+    v "template-haskell" [2,8,0,0],+    v "time" [1,4,0,1],+    v "unix" [2,6,0,1]+    ]  -- Removed: rts, extensible-exceptions ghc761BuiltIns :: [PackageIdentifier]

@@ -163,8 +163,8 @@       , preDepends :: Relations       , breaks :: Relations       , conflicts :: Relations-      , provides :: Relations-      , replaces :: Relations+      , provides_ :: Relations+      , replaces_ :: Relations       , builtUsing :: Relations       } deriving (Eq, Ord, Read, Show, Data, Typeable) @@ -177,8 +177,8 @@       , preDepends = []       , breaks = []       , conflicts = []-      , provides = []-      , replaces = []+      , provides_ = []+      , replaces_ = []       , builtUsing = [] }  -- ^ The different types of binary debs we can produce from a haskell package

@@ -37,17 +37,18 @@ import Debian.Debianize.Dependencies (debianName) import Debian.Debianize.Files (toFileMap) import Debian.Debianize.Finalize (finalizeDebianization)-import Debian.Debianize.Goodies (defaultAtoms, watchAtom)-import Debian.Debianize.Input (inputDebianization, inputCabalization, inputCopyright, inputMaintainer, inputChangeLog)+import Debian.Debianize.Goodies (watchAtom)+import Debian.Debianize.Input (inputDebianization, inputCabalization, inputLicenseFile, inputMaintainer, inputChangeLog) import Debian.Debianize.Options (options, compileArgs) import Debian.Debianize.SubstVars (substvars)-import Debian.Debianize.Types (DebAction(..))+import Debian.Debianize.Types (DebAction(..), Top(Top, unTop)) import Debian.Debianize.Utility (withCurrentDirectory, foldEmpty, replaceFile, zipMaps, indent) import Debian.Policy (PackagePriority(Optional), Section(MainSection), getDebhelperCompatLevel) import Debian.Relation (SrcPkgName(..), BinPkgName(BinPkgName), Relation(Rel)) import Debian.Release (parseReleaseName) import Debian.Version (DebianVersion, parseDebianVersion, buildDebianVersion) import Debian.Time (getCurrentLocalRFC822Time)+import Distribution.License (License(AllRightsReserved)) import Distribution.Package (PackageIdentifier(..)) import qualified Distribution.PackageDescription as Cabal #if __GLASGOW_HASKELL__ < 706@@ -57,7 +58,7 @@ #endif import System.Console.GetOpt (usageInfo) import System.Directory (doesFileExist, Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing)-import System.Environment (getArgs, getEnv, getProgName)+import System.Environment (getArgs, getEnv, getProgName, withArgs) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((</>), takeDirectory) import System.IO.Error (catchIOError)@@ -67,13 +68,13 @@ import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))  -- | The main function for the cabal-debian executable.-cabalDebian :: IO ()-cabalDebian =+cabalDebian :: Atoms -> IO ()+cabalDebian defaultAtoms =     compileEnvironmentArgs defaultAtoms >>=     compileCommandlineArgs >>= \ atoms ->       case getL debAction atoms of         SubstVar debType -> substvars atoms debType-        Debianize -> debianize "." atoms+        Debianize -> debianize (Top ".") return defaultAtoms         Usage -> do           progName <- getProgName           let info = "Usage: " ++ progName ++ " [FLAGS]\n"@@ -90,11 +91,9 @@ -- debianize function.  This is basically equivalent to @cabal-debian -- --debianize@, except that the command line arguments come from the -- function parameter.-callDebianize :: [String] -> IO ()-callDebianize args =-    compileEnvironmentArgs defaultAtoms >>=-    return . compileArgs args >>=-    debianize "."+callDebianize :: [String] -> Atoms -> IO ()+callDebianize args defaultAtoms =+    withArgs args (debianize (Top ".") return defaultAtoms)  -- | Put an argument list into the @CABALDEBIAN@ environment variable -- and then run the script in debian/Debianize.hs.  If this exists and@@ -105,11 +104,13 @@ -- available to the cabal-debian executable. runDebianize :: [String] -> IO Bool runDebianize args =+    getEnv "HOME" >>= \ home ->     doesFileExist "debian/Debianize.hs" >>= \ exists ->     case exists of       False -> return False       True ->-          putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ("debian/Debianize.hs" : args) "" >>= \ result ->+          let autobuilderd = "-i.:" ++ home </> ".autobuilder.d" in+          putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ([autobuilderd, "debian/Debianize.hs"] ++ args) "" >>= \ result ->           case result of             (ExitSuccess, _, _) -> return True             (code, out, err) ->@@ -122,35 +123,40 @@ putEnvironmentArgs fs = setEnv "CABALDEBIAN" (show fs) True  -- | Call runDebianize with the given working directory.-runDebianize' :: FilePath -> [String] -> IO Bool-runDebianize' top args = withCurrentDirectory top $ runDebianize args+runDebianize' :: Top -> [String] -> IO Bool+runDebianize' top args = withCurrentDirectory (unTop top) $ runDebianize args  -- | Depending on the options in @atoms@, either validate, describe, -- or write the generated debianization.-debianize :: FilePath -> Atoms -> IO ()-debianize top atoms =-    debianization top atoms >>= \ atoms' ->-    if getL validate atoms'-    then inputDebianization top >>= \ old -> return (validateDebianization old atoms')-    else if getL dryRun atoms'-         then inputDebianization top >>= \ old -> putStr ("Debianization (dry run):\n" ++ compareDebianization old atoms')-         else writeDebianization top atoms'+debianize :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO ()+debianize top customize defaultAtoms =+    debianization top customize defaultAtoms >>= \ atoms ->+    if getL validate atoms+    then inputDebianization top >>= \ old -> return (validateDebianization old atoms)+    else if getL dryRun atoms+         then inputDebianization top >>= \ old -> putStr ("Debianization (dry run):\n" ++ compareDebianization (ensureCopyright old) atoms)+         else writeDebianization top atoms+    where+      ensureCopyright = modL copyright (maybe (Just (Left AllRightsReserved)) Just)  -- | Given an Atoms value, get any additional configuration -- information from the environment, read the cabal package -- description and possibly the debian/changelog file, then generate -- and return the new debianization (along with the data directory -- computed from the cabal package description.)-debianization :: FilePath -> Atoms -> IO Atoms-debianization top atoms =-    do log <- (Just <$> inputChangeLog "debian") `catch` (\ (_ :: IOError) -> return Nothing)-       atoms' <- inputCabalization top atoms+debianization :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO Atoms+debianization top customize defaultAtoms =+    do atoms <- compileEnvironmentArgs defaultAtoms >>=+                compileCommandlineArgs >>=+                customize >>=+                inputCabalization top+       log <- (Just <$> inputChangeLog top) `catch` (\ (_ :: IOError) -> return Nothing)        date <- getCurrentLocalRFC822Time-       maint <- inputMaintainer atoms' >>= maybe (error "Missing value for --maintainer") return+       maint <- inputMaintainer atoms >>= maybe (error "Missing value for --maintainer") return        level <- getDebhelperCompatLevel-       copyright <- withCurrentDirectory top $ inputCopyright (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ show top)-                                                                         (getL packageDescription atoms'))-       return $ debianization' date copyright maint level log atoms'+       copyright <- withCurrentDirectory (unTop top) $ inputLicenseFile (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ unTop top)+                                                                         (getL packageDescription atoms))+       return $ debianization' date copyright maint level log atoms  debianization' :: String              -- ^ current date                -> Maybe Text          -- ^ copyright@@ -257,9 +263,9 @@ anyrel' x = [Rel x Nothing Nothing]  -- | Write the files of the debianization @d@ to the directory @top@.-writeDebianization :: FilePath -> Atoms -> IO ()+writeDebianization :: Top -> Atoms -> IO () writeDebianization top d =-    withCurrentDirectory top $+    withCurrentDirectory (unTop top) $       mapM_ (\ (path, text) ->                  createDirectoryIfMissing True (takeDirectory path) >>                  replaceFile path (unpack text))

@@ -8,31 +8,34 @@     , putBuildDeps     , dependencies     , debianName+    , debianName'     , debNameFromType     , getRulesHead     , filterMissing     , binaryPackageDeps     , binaryPackageConflicts+    , binaryPackageProvides+    , binaryPackageReplaces     ) where  import Data.Char (isSpace, toLower) import Data.Function (on) import Data.Lens.Lazy (getL, modL) import Data.List as List (nub, minimumBy, isSuffixOf, map)-import Data.Map as Map (Map, lookup, insertWith, empty)+import Data.Map as Map (Map, lookup) import Data.Maybe (fromMaybe, catMaybes, listToMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text as Text (Text, pack, unlines)-import Data.Version (Version, showVersion)+import Data.Version (showVersion) import Debian.Control import Debian.Debianize.Atoms (Atoms, packageDescription, rulesHead, compiler, noProfilingLibrary, noDocumentationLibrary,-                               missingDependencies, versionSplits, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap,-                               packageInfo, depends, conflicts, control)+                               missingDependencies, debianNameMap, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap,+                               packageInfo, depends, conflicts, provides, replaces, control) import Debian.Debianize.Bundled (ghcBuiltIn) import Debian.Debianize.ControlFile as Debian (PackageType(..), SourceDebDescription(..))-import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples)-import Debian.Debianize.Types (PackageInfo(devDeb, profDeb, docDeb), VersionSplits(..), DebType(..))+import Debian.Debianize.Types (PackageInfo(devDeb, profDeb, docDeb), DebType(..))+import Debian.Debianize.Types.VersionSplits (VersionSplits, doSplits, packageRangesFromVersionSplits) import Debian.Orphans () import qualified Debian.Relation as D import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(pkgNameFromString))@@ -122,7 +125,7 @@            [D.Rel (D.BinPkgName "haskell-devscripts") (Just (D.GRE (parseDebianVersion ("0.8" :: String)))) Nothing],            anyrel "cdbs",            anyrel "ghc"] ++-            (map anyrel' (Set.toList (getL buildDeps deb))) +++            (map (: []) (Set.toList (getL buildDeps deb))) ++             (if getL noProfilingLibrary deb then [] else [anyrel "ghc-prof"]) ++             cabalDeps (getL packageDescription deb)     where@@ -141,7 +144,7 @@     if getL noDocumentationLibrary deb     then []     else nub $ [anyrel "ghc-doc"] ++-               (map anyrel' (Set.toList (getL buildDepsIndep deb))) +++               (map (: []) (Set.toList (getL buildDepsIndep deb))) ++                cabalDeps (getL packageDescription deb)     where       cabalDeps Nothing = []@@ -224,11 +227,11 @@       -- we may need to distribute any "and" dependencies implied       -- by a version range over these "or" dependences.       alts :: [(BinPkgName, VersionRange)]-      alts = case Map.lookup name (packageSplits (getL versionSplits atoms)) of+      alts = case Map.lookup name (getL debianNameMap atoms) of                -- If there are no splits for this package just return the single dependency for the package                Nothing -> [(mkPkgName name typ, cabalRange')]                -- If there are splits create a list of (debian package name, VersionRange) pairs-               Just splits' -> map (\ (n, r) -> (mkPkgName n typ, r)) (packageRangesFromVersionSplits splits')+               Just splits' -> map (\ (n, r) -> (mkPkgName' n typ, r)) (packageRangesFromVersionSplits splits')        convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation)       convert (dname, range) =@@ -247,7 +250,7 @@                  (\ x y -> And [x, y])                  id                  range'''-          where +          where             -- Choose the simpler of the two             range''' = canon (simpler range' range'')             -- Unrestrict the range for versions that we know don't exist for this debian package@@ -300,37 +303,21 @@ canonical (And rels) = And $ concatMap (unAnd . canonical) rels canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels +debianName :: (PkgName name) => Atoms -> PackageType -> PackageIdentifier -> name+debianName atoms typ pkgDesc = debianName' (Map.lookup (pkgName pkgDesc) (getL debianNameMap atoms)) typ pkgDesc+ -- | 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.-debianName :: (PkgName name) => Atoms -> PackageType -> PackageIdentifier -> name-debianName atoms typ pkgDesc =-    (\ pname -> mkPkgName pname typ) $-    case filter (\ x -> pname == packageName x) (getL versionSplits atoms) of-      [] -> pname-      [splits] ->-          foldTriples' (\ ltName v geName debName ->-                           if pname /= packageName splits-                           then debName-                           else let split = parseDebianVersion (showVersion v) in-                                case version of-                                  Nothing -> geName-                                  Just (D.SLT v') | v' <= split -> ltName-                                  -- Otherwise use ltName only when the split is below v'-                                  Just (D.EEQ v') | v' < split -> ltName-                                  Just (D.LTE v') | v' < split -> ltName-                                  Just (D.GRE v') | v' < split -> ltName-                                  Just (D.SGR v') | v' < split -> ltName-                                  _ -> geName)-                       pname-                       splits-      _ -> error $ "Multiple splits for cabal package " ++ string+debianName' :: (PkgName name) => Maybe VersionSplits -> PackageType -> PackageIdentifier -> name+debianName' msplits typ pkgDesc =+    case msplits of+      Nothing -> mkPkgName pname typ+      Just splits -> (\ s -> mkPkgName' s typ) $ doSplits splits version     where-      foldTriples' :: (PackageName -> Version -> PackageName -> PackageName -> PackageName) -> PackageName -> VersionSplits -> PackageName-      foldTriples' = foldTriples       -- def = mkPkgName pname typ-      pname@(PackageName string) = pkgName pkgDesc+      pname@(PackageName _) = pkgName pkgDesc       version = (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion pkgDesc)))))  -- | Given a control file and a DebType, look for the binary deb with@@ -349,7 +336,10 @@ -- correspondence between the PackageType value and the name type, so -- it can return nonsense like (SrcPkgName "libghc-debian-dev"). mkPkgName :: PkgName name => PackageName -> PackageType -> name-mkPkgName (PackageName name) typ =+mkPkgName pkg typ = mkPkgName' (debianBaseName pkg) typ++mkPkgName' :: PkgName name => String -> PackageType -> name+mkPkgName' base typ =     pkgNameFromString $              case typ of                 Documentation -> "libghc-" ++ base ++ "-doc"@@ -359,35 +349,16 @@                 Exec -> base                 Source' -> "haskell-" ++ base ++ ""                 Cabal -> base++debianBaseName :: PackageName -> String+debianBaseName (PackageName name) =+    map (fixChar . toLower) name     where-      base = map (fixChar . toLower) name       -- Underscore is prohibited in debian package names.       fixChar :: Char -> Char       fixChar '_' = '-'       fixChar c = toLower c -instance Interspersed VersionSplits PackageName Version where-    leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance"-    leftmost (VersionSplits {oldestPackage = p}) = p-    pairs (VersionSplits {splits = xs}) = xs--packageSplits :: [VersionSplits] -> Map PackageName VersionSplits-packageSplits splits =-    foldr (\ splits' mp -> Map.insertWith multipleSplitsError (packageName splits') splits' mp)-          Map.empty-          splits-    where-      multipleSplitsError :: VersionSplits -> a -> b-      multipleSplitsError (VersionSplits {packageName = PackageName p}) _s2 =-          error ("Multiple splits for package " ++ show p)--packageRangesFromVersionSplits :: VersionSplits -> [(PackageName, VersionRange)]-packageRangesFromVersionSplits splits =-    foldInverted (\ older dname newer more ->-                      (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more)-                 []-                 splits- {- -- | Generate the head of the debian/rules file. cdbsRules :: PackageIdentifier -> Atoms -> Atoms@@ -429,3 +400,9 @@  binaryPackageConflicts :: BinPkgName -> Atoms -> [[Relation]] binaryPackageConflicts b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL conflicts atoms))++binaryPackageReplaces :: BinPkgName -> Atoms -> [[Relation]]+binaryPackageReplaces b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL replaces atoms))++binaryPackageProvides :: BinPkgName -> Atoms -> [[Relation]]+binaryPackageProvides b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL provides atoms))

@@ -0,0 +1,45 @@+{-# OPTIONS -Wall #-}+module Debian.Debianize.Details+    ( debianDefaultAtoms+    , seereasonDefaultAtoms+    ) where++import Data.Lens.Lazy (modL, setL)+import Data.Map as Map (fromList)+import Data.Monoid (mempty)+import Data.Set as Set (insert)+import Debian.Relation (BinPkgName(BinPkgName))+import Data.Version (Version(Version))+import Debian.Debianize (Atoms, missingDependencies, epochMap)+import Debian.Debianize.VersionSplits (mapCabal, splitCabal)+import Distribution.Package (PackageName(PackageName))++debianDefaultAtoms :: Atoms+debianDefaultAtoms =+    setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) .+    splitCabal (PackageName "parsec") "parsec2" (Version [3] []) .+    mapCabal (PackageName "parsec") "parsec3" .+    splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) .+    mapCabal (PackageName "QuickCheck") "quickcheck2" .+    mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $+    mempty++seereasonDefaultAtoms :: Atoms+seereasonDefaultAtoms =+    modL missingDependencies (Set.insert (BinPkgName "libghc-happstack-authenticate-9-doc")) .++    splitCabal (PackageName "clckwrks") "clckwrks-13" (Version [0, 14] []) .+    splitCabal (PackageName "clckwrks") "clckwrks-14" (Version [0, 15] []) .+    mapCabal (PackageName "clckwrks") "clckwrks" .+    splitCabal (PackageName "blaze-html") "blaze-html-5" (Version [0, 6] []) .+    mapCabal (PackageName "blaze-html") "blaze-html" .+    splitCabal (PackageName "happstack-authenticate") "happstack-authenticate-9" (Version [0, 10] []) .+    mapCabal (PackageName "happstack-authenticate") "happstack-authenticate" .+    splitCabal (PackageName "http-types") "http-types-7" (Version [0, 8] []) .+    mapCabal (PackageName "http-types") "http-types" .+    splitCabal (PackageName "web-plugins") "web-plugins-1" (Version [0, 2] []) .+    mapCabal (PackageName "web-plugins") "web-plugins" .+    splitCabal (PackageName "case-insensitive") "case-insensitive-0" (Version [1] []) .+    mapCabal (PackageName "case-insensitive") "case-insensitive" $++    debianDefaultAtoms

@@ -45,7 +45,7 @@  dirs :: Atoms -> [(FilePath, Text)] dirs deb =-    map (\ (path, dirs) -> (path, pack (List.unlines (Set.toList dirs)))) $ Map.toList $ mapKeys pathf $ getL installDir deb+    map (\ (path, dirs') -> (path, pack (List.unlines (Set.toList dirs')))) $ Map.toList $ mapKeys pathf $ getL installDir deb     where       pathf name = "debian" </> show (pretty name) ++ ".dirs" @@ -109,7 +109,7 @@        ("debian/changelog", pack (show (pretty (fromMaybe (error "Missing debian/changelog") (getL changelog atoms))))),        ("debian/rules", rules atoms),        ("debian/compat", pack (show (fromMaybe (error "Missing DebCompat atom") $ getL compat atoms) <> "\n")),-       ("debian/copyright", either (\ x -> pack (show x) <> "\n") id (fromMaybe (error "No DebCopyright atom") $ getL copyright atoms))] +++       ("debian/copyright", either (\ x -> pack (show (pretty x))) id (fromMaybe (error ("No DebCopyright atom: " ++ show atoms)) $ getL copyright atoms))] ++       sourceFormatFiles atoms ++       watchFile atoms ++       installs atoms ++@@ -142,7 +142,7 @@             depField "Build-Depends-Indep" (buildDependsIndep src) ++             depField "Build-Conflicts" (buildConflicts src) ++             depField "Build-Conflicts-Indep" (buildConflictsIndep src) ++-            [Field ("Standards-Version", " " <> show (pretty (standardsVersion src)))] +++            mField "Standards-Version" (standardsVersion src) ++             mField "Homepage" (homepage src) ++             List.map vcsField (Set.toList (vcsFields src)) ++             List.map xField (Set.toList (xFields src))) :@@ -191,8 +191,8 @@     depField "Pre-Depends" (preDepends rels) ++     depField "Breaks" (breaks rels) ++     depField "Conflicts" (conflicts rels) ++-    depField "Provides" (provides rels) ++-    depField "Replaces" (replaces rels) +++    depField "Provides" (provides_ rels) +++    depField "Replaces" (replaces_ rels) ++     depField "Built-Using" (builtUsing rels)  depField :: [Char] -> Relations -> [Field' [Char]]

@@ -24,14 +24,14 @@ import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..),                                                newBinaryDebDescription, modifyBinaryDeb,                                                PackageType(Exec, Development, Profiling, Documentation, Utilities))-import Debian.Debianize.Dependencies (debianName, binaryPackageDeps, binaryPackageConflicts, putBuildDeps)+import Debian.Debianize.Dependencies (debianName, binaryPackageDeps, binaryPackageConflicts, binaryPackageProvides, binaryPackageReplaces, putBuildDeps) import Debian.Debianize.Goodies (describe, siteAtoms, serverAtoms, backupAtoms, execAtoms) import Debian.Debianize.Types (InstallFile(..)) import Debian.Policy (PackageArchitectures(Any, All), Section(..)) import Debian.Relation (Relation(Rel), BinPkgName(BinPkgName)) import Distribution.Package (PackageName(PackageName), PackageIdentifier(..)) import qualified Distribution.PackageDescription as Cabal-import Prelude hiding (init, unlines, writeFile, map)+import Prelude hiding (init, unlines, writeFile, map, log) import System.FilePath ((</>), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName) import Text.PrettyPrint.ANSI.Leijen (pretty) @@ -42,8 +42,8 @@ -- debianization in other ways, so be careful not to do this twice, -- this function is not idempotent.  (Exported for use in unit tests.) finalizeDebianization  :: Atoms -> Atoms-finalizeDebianization atoms =-    g $ finalizeAtoms $ makeUtilsPackage $ librarySpecs $ putBuildDeps $ f $ finalizeAtoms $ atoms+finalizeDebianization atoms0 =+    g $ finalizeAtoms $ makeUtilsPackage $ librarySpecs $ putBuildDeps $ f $ finalizeAtoms $ atoms0     where        -- Create the binary packages for the web sites, servers, backup packges, and other executables@@ -80,15 +80,15 @@ binaryPackageRelations b typ deb =     PackageRelations     { Debian.depends = [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++-                       (if typ == Development then List.map anyrel' (toList (getL extraDevDeps deb)) else []) +++                       (if typ == Development then List.map (: []) (toList (getL extraDevDeps deb)) else []) ++                        binaryPackageDeps b deb     , recommends = [anyrel "${haskell:Recommends}"]     , suggests = [anyrel "${haskell:Suggests}"]     , preDepends = []     , breaks = []     , conflicts = [anyrel "${haskell:Conflicts}"] ++ binaryPackageConflicts b deb-    , provides = [anyrel "${haskell:Provides}"]-    , replaces = []+    , provides_ = [anyrel "${haskell:Provides}"] ++ binaryPackageProvides b deb+    , replaces_ = [anyrel "${haskell:Replaces}"] ++ binaryPackageReplaces b deb     , builtUsing = []     } @@ -235,7 +235,7 @@                            Set.fold (\ (n, d) atoms' ->                                          modL rulesFragments (Set.insert (Text.unlines                                                                           [ pack ("binary-fixup" </> show (pretty b)) <> "::"-                                                                          , "\tinstall -Dp " <> pack (builddir </> n </> n) <> " " <> pack ("debian" </> show (pretty b) </> makeRelative "/" d) ])) atoms')+                                                                          , "\tinstall -Dps " <> pack (builddir </> n </> n) <> " " <> pack ("debian" </> show (pretty b) </> makeRelative "/" d) ])) atoms')                                     atoms                                     pairs)                       new

@@ -1,108 +0,0 @@--- | Some generic operations with specializations to avoid broken Data--- instances in types like Text and Set.-{-# LANGUAGE  DeriveDataTypeable, RankNTypes, StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Debian.Debianize.Generic-    ( geq-    , gdiff-    , gshow-    ) where--import Prelude hiding (GT)-import Data.Generics (Data, Typeable, GenericQ, toConstr, showConstr, gzipWithQ, extQ, ext1Q, gmapQ, Constr {- , ext2Q, Typeable2, dataTypeName, dataTypeOf-})-import Data.List (sort)-import qualified Data.Text as T-import Data.Set as Set (Set, toList, fromList, difference)-import Debian.Debianize.Atoms (Atoms)-import Debian.Debianize.ControlFile (VersionControlSpec, XField)-import Debian.Debianize.Utility (showDeps)-import Debian.Relation (Relation)-import Triplets (mkQ2, extQ2)---- These instances are only used here, to create debugging messages.-deriving instance Typeable Atoms---- deriving instance Data Debianization--- deriving instance Data DebAtom---- ext2Q' :: (Data d, Typeable2 t) => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q--- ext2Q' = ext2Q--geq :: GenericQ (GenericQ Bool)-geq x y =-    (geq' `mkQ2` stringEq `extQ2` textEq `extQ2` setEq1 `extQ2` setEq2 `extQ2` mapEq1) x y-    where-      -- If the specialized eqs don't work, use the generic.  This-      -- will throw an exception if it encounters something with a-      -- NoRep type.-      geq' :: (Data a, Data b) => a -> b -> Bool-      geq' x' y' = (toConstr x' == toConstr y') && and (gzipWithQ geq x' y')-      stringEq :: String -> String -> Bool-      stringEq a b = (a == b)-      textEq :: T.Text -> T.Text -> Bool-      textEq a b = (a == b)-      setEq1 :: Set VersionControlSpec -> Set VersionControlSpec -> Bool-      setEq1 a b = toList a == toList b-      setEq2 :: Set XField -> Set XField -> Bool-      setEq2 a b = toList a == toList b-      mapEq1 :: Atoms -> Atoms -> Bool-      mapEq1 a b = (a == b)--data Diff-    = Diff { stack :: [Constr], expected :: String, actual :: String }-    | SetDiff { stack :: [Constr], expected :: String, missing :: String, extra :: String }-    deriving (Eq, Show)--gdiff :: GenericQ (GenericQ [Diff])-gdiff x y =-    (gdiff' `mkQ2` stringEq `extQ2` textEq `extQ2` setEq1 `extQ2` setEq2 `extQ2` mapEq1 `extQ2` relEq) x y-    where-      -- If the specialized eqs don't work, use the generic.  This-      -- will throw an exception if it encounters something with a-      -- NoRep type.-      gdiff' :: (Data a, Data b) => a -> b -> [Diff]-      gdiff' x' y' =-          if toConstr x' == toConstr y'-          then map (\ diff -> diff {stack = toConstr x' : stack diff}) (concat (gzipWithQ gdiff x' y'))-          else [Diff {stack = [], expected = gshow x', actual = gshow y'}]-      stringEq :: String -> String -> [Diff]-      stringEq a b = if (a == b) then [] else [Diff {stack = [], expected = show a, actual = show b}]-      textEq :: T.Text -> T.Text -> [Diff]-      textEq a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}]-      setEq1 :: Set VersionControlSpec -> Set VersionControlSpec -> [Diff]-      setEq1 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}]-      setEq2 :: Set XField -> Set XField -> [Diff]-      setEq2 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}]-      mapEq1 :: Atoms -> Atoms -> [Diff]-      mapEq1 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}]-      relEq :: [[Relation]] -> [[Relation]] -> [Diff]-      relEq a b = if Set.fromList a == Set.fromList b-                  then []-                  else [SetDiff {stack = [],-                                 expected = show [a, b],-                                 missing = showDeps (sort (Set.toList (Set.difference (Set.fromList a) (Set.fromList b)))),-                                 extra = showDeps (sort (Set.toList (Set.difference (Set.fromList b) (Set.fromList a))))}]--{--gshow' :: Data a => a -> String-gshow' x =-    (gshow `extQ` (show :: T.Text -> String) `extQ` (show :: Maybe T.Text -> String)) x--}---- | Generic show: an alternative to \"deriving Show\"-gshow :: Data a => a -> String-gshow x = gshows x ""---- | Generic shows-gshows :: Data a => a -> ShowS---- This is a prefix-show using surrounding "(" and ")",--- where we recurse into subterms with gmapQ.-gshows = ( \t ->-                showChar '('-              . (showString . showConstr . toConstr $ t)-              . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t)-              . showChar ')'-         ) `extQ` (shows :: String -> ShowS)-           `extQ` ((shows . T.unpack) :: T.Text -> ShowS)-           `ext1Q` (\ s -> gshows (toList s))

@@ -2,8 +2,7 @@ -- are instead included as part of the library. {-# LANGUAGE OverloadedStrings #-} module Debian.Debianize.Goodies-    ( defaultAtoms-    , tightDependencyFixup+    ( tightDependencyFixup     , doServer     , doWebsite     , doBackups@@ -19,22 +18,21 @@     , execAtoms     ) where -import Data.Lens.Lazy (getL, setL, modL)+import Data.Lens.Lazy (getL, modL) import Data.List as List (map, intersperse, intercalate)-import Data.Map as Map (Map, fromList, insertWith)+import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe)-import Data.Monoid (mempty, (<>))+import Data.Monoid ((<>)) import Data.Set as Set (insert, union, singleton) import Data.Text as Text (Text, pack, unlines, intercalate)-import Data.Version (Version(Version)) import Debian.Debianize.Atoms as Atoms () import Debian.Debianize.Atoms as Atoms     (Atoms, packageDescription, rulesFragments, website, serverInfo, link, backups, executable,      install, installTo, installCabalExecTo, file, installDir, logrotateStanza, postInst,      installInit, installCabalExec, rulesFragments, packageDescription, executable,-     serverInfo, website, backups, depends, epochMap, versionSplits)+     serverInfo, website, backups, depends) import Debian.Debianize.ControlFile as Debian (PackageType(..))-import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), VersionSplits(..))+import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..)) import Debian.Debianize.Utility (trim) import Debian.Orphans () import Debian.Policy (apacheLogDirectory, apacheErrorLog, apacheAccessLog, databaseDirectory, serverAppLog, serverAccessLog)@@ -46,6 +44,7 @@ import System.FilePath ((</>)) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) +showCommand :: String -> [String] -> String showCommand cmd args =     unwords (map translate (cmd : args)) @@ -56,37 +55,6 @@       escape '"' = showString "\\\""       escape c = showChar c --- | This may not look like a goodie, but it incorporates knowledge--- about the debian repository - what the epoch number of HaXml is,--- the fact that the debian package name of parsec changed, etc.-defaultAtoms :: Atoms-defaultAtoms =-    setL epochMap knownEpochMappings $-    setL versionSplits knownVersionSplits $-    mempty---- | These are the instances of debian names changing that I know--- about.  I know they really shouldn't be hard coded.  Send a patch.--- Note that this inherits the lack of type safety of the mkPkgName--- function.-knownVersionSplits :: [VersionSplits]-knownVersionSplits =-    [ VersionSplits {-        packageName = PackageName "parsec"-      , oldestPackage = PackageName "parsec2"-      , splits = [(Version [3] [], PackageName "parsec3")] }-    , VersionSplits {-        packageName = PackageName "QuickCheck"-      , oldestPackage = PackageName "quickcheck1"-      , splits = [(Version [2] [], PackageName "quickcheck2")] }-    ]---- | We should always call this, just as we should always apply--- knownVersionSplits.-knownEpochMappings :: Map PackageName Int-knownEpochMappings =-    Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]- -- | Create equals dependencies.  For each pair (A, B), use dpkg-query -- to find out B's version number, version B.  Then write a rule into -- P's .substvar that makes P require that that exact version of A,@@ -268,19 +236,19 @@       port' = pack (show (port (server site)))  serverAtoms :: BinPkgName -> Server -> Bool -> Atoms -> Atoms-serverAtoms b server isSite =+serverAtoms b server' isSite =     modL postInst (insertWith (error "serverAtoms") b debianPostinst) .     modL installInit (Map.insertWith (error "serverAtoms") b debianInit) .     serverLogrotate' b .     execAtoms b exec     where-      exec = installFile server+      exec = installFile server'       debianInit =           Text.unlines $                    [ "#! /bin/sh -e"                    , ""                    , ". /lib/lsb/init-functions"-                   , ". /etc/default/" <> pack (destName exec) <> " || true"+                   , "test -f /etc/default/" <> pack (destName exec) <> " && . /etc/default/" <> pack (destName exec)                    , ""                    , "case \"$1\" in"                    , "  start)"@@ -301,14 +269,11 @@                    , "esac"                    , ""                    , "exit 0" ]-      startCommand = pack $ showCommand "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverOptions)+      startCommand = pack $ showCommand "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverFlags server')       stopCommand = pack $ showCommand "start-stop-daemon" (stopOptions ++ commonOptions)       commonOptions = ["--pidfile", "/var/run/" ++ destName exec]       startOptions = ["--start", "-b", "--make-pidfile", "-d", databaseDirectory b, "--exec", "/usr/bin" </> destName exec]-      stopOptions = ["--stop", "--oknodo"] ++ if retry server /= "" then ["--retry=" ++ retry server ] else []-      serverOptions = serverFlags server ++ commonServerOptions-      -- Without these, happstack servers chew up CPU even when idle-      commonServerOptions = ["+RTS", "-IO", "-RTS"]+      stopOptions = ["--stop", "--oknodo"] ++ if retry server' /= "" then ["--retry=" ++ retry server' ] else []        debianPostinst =           Text.unlines $@@ -373,15 +338,15 @@     r  fileAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms-fileAtoms b installFile r =-    fileAtoms' b (sourceDir installFile) (execName installFile) (destDir installFile) (destName installFile) r+fileAtoms b installFile' r =+    fileAtoms' b (sourceDir installFile') (execName installFile') (destDir installFile') (destName installFile') r  fileAtoms' :: BinPkgName -> Maybe FilePath -> String -> Maybe FilePath -> String -> Atoms -> Atoms-fileAtoms' b sourceDir execName destDir destName r =-    case (sourceDir, execName == destName) of-      (Nothing, True) -> modL installCabalExec (insertWith Set.union b (singleton (execName, d))) r-      (Just s, True) -> modL install (insertWith Set.union b (singleton (s </> execName, d))) r-      (Nothing, False) -> modL installCabalExecTo (insertWith Set.union b (singleton (execName, (d </> destName)))) r-      (Just s, False) -> modL installTo (insertWith Set.union b (singleton (s </> execName, d </> destName))) r+fileAtoms' b sourceDir' execName' destDir' destName' r =+    case (sourceDir', execName' == destName') of+      (Nothing, True) -> modL installCabalExec (insertWith Set.union b (singleton (execName', d))) r+      (Just s, True) -> modL install (insertWith Set.union b (singleton (s </> execName', d))) r+      (Nothing, False) -> modL installCabalExecTo (insertWith Set.union b (singleton (execName', (d </> destName')))) r+      (Just s, False) -> modL installTo (insertWith Set.union b (singleton (s </> execName', d </> destName'))) r     where-      d = fromMaybe "usr/bin" destDir+      d = fromMaybe "usr/bin" destDir'

@@ -3,15 +3,15 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.Debianize.Input     ( inputDebianization+    , inputDebianizationFile     , inputChangeLog     , inputCabalization-    , inputCopyright+    , inputLicenseFile     , inputMaintainer     ) where  import Debug.Trace (trace) -import Control.Applicative ((<$>)) import Control.Exception (bracket) import Control.Monad (when, foldM, filterM) import Control.Monad.Trans (MonadIO, liftIO)@@ -32,12 +32,12 @@      compilerVersion, cabalFlagAssignments) import Debian.Debianize.ControlFile (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..),                                      VersionControlSpec(..), XField(..), newSourceDebDescription', newBinaryDebDescription)-import Debian.Debianize.Utility (getDirectoryContents', readFile', withCurrentDirectory)+import Debian.Debianize.Types (Top(Top, unTop))+import Debian.Debianize.Utility (getDirectoryContents', withCurrentDirectory, readFileMaybe) import Debian.Orphans () import Debian.Policy (Section(..), parseStandardsVersion, readPriority, readSection, parsePackageArchitectures, parseMaintainer,                       parseUploaders, readSourceFormat, getDebianMaintainer, haskellMaintainer) import Debian.Relation (Relations, BinPkgName(..), SrcPkgName(..), parseRelations)---import Distribution.License (License(..)) import Distribution.Package (Package(packageId)) import Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, maintainer)) import Distribution.PackageDescription.Configuration (finalizePackageDescription)@@ -57,17 +57,20 @@ import System.IO.Error (catchIOError) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) -inputDebianization :: FilePath -> IO Atoms+inputDebianization :: Top -> IO Atoms inputDebianization top =-    do (ctl, _) <- inputSourceDebDescription debian-       atoms <- inputAtomsFromDirectory debian mempty+    do (ctl, _) <- inputSourceDebDescription top+       atoms <- inputAtomsFromDirectory top mempty        return $ modL control (const ctl) atoms-    where-      debian = top </> "debian" -inputSourceDebDescription :: FilePath -> IO (SourceDebDescription, [Field])-inputSourceDebDescription debian =-    do paras <- parseControlFromFile (debian </> "control") >>= either (error . show) (return . unControl)+-- | Try to input a file and if successful add it to the debianization.+inputDebianizationFile :: Top -> FilePath -> Atoms -> IO Atoms+inputDebianizationFile (Top top) path atoms =+    readFileMaybe (top </> path) >>= return . maybe atoms (\ text -> modL intermediateFiles (insert (path, text)) atoms)++inputSourceDebDescription :: Top -> IO (SourceDebDescription, [Field])+inputSourceDebDescription top =+    do paras <- parseControlFromFile (unTop top </> "debian/control") >>= either (error . show) (return . unControl)        case paras of          [] -> error "Missing source paragraph"          [_] -> error "Missing binary paragraph"@@ -80,7 +83,7 @@       fields' = map stripField fields       src = (newSourceDebDescription' findSource findMaint) {binaryPackages = bins}       findSource = findMap "Source" SrcPkgName fields'-      findMaint = findMap "Maintainer" (either error id . parseMaintainer) fields'+      findMaint = findMap "Maintainer" (\ m -> either (\ e -> error $ "Failed to parse maintainer field " ++ show m ++ ": " ++ show e) id . parseMaintainer $ m) fields'       -- findStandards = findMap "Standards-Version" parseStandardsVersion fields'        (bins, _extra) = unzip $ map parseBinaryDebDescription binaryParagraphs@@ -143,8 +146,8 @@       readField (Field ("Pre-Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {preDepends = rels value}}, unrecognized)       readField (Field ("Breaks", value)) (desc, unrecognized) = (desc {relations = (relations desc) {breaks = rels value}}, unrecognized)       readField (Field ("Conflicts", value)) (desc, unrecognized) = (desc {relations = (relations desc) {conflicts = rels value}}, unrecognized)-      readField (Field ("Provides", value)) (desc, unrecognized) = (desc {relations = (relations desc) {provides = rels value}}, unrecognized)-      readField (Field ("Replaces", value)) (desc, unrecognized) = (desc {relations = (relations desc) {replaces = rels value}}, unrecognized)+      readField (Field ("Provides", value)) (desc, unrecognized) = (desc {relations = (relations desc) {provides_ = rels value}}, unrecognized)+      readField (Field ("Replaces", value)) (desc, unrecognized) = (desc {relations = (relations desc) {replaces_ = rels value}}, unrecognized)       readField (Field ("Built-Using", value)) (desc, unrecognized) = (desc {relations = (relations desc) {builtUsing = rels value}}, unrecognized)       readField (Field ("Description", value)) (desc, unrecognized) = (desc {description = pack value}, unrecognized)       readField field (desc, unrecognized) = (desc, field : unrecognized)@@ -173,23 +176,23 @@ yes "no" = False yes x = error $ "Expecting yes or no: " ++ x -inputChangeLog :: FilePath -> IO ChangeLog-inputChangeLog debian = readFile (debian </> "changelog") >>= return . parseChangeLog . unpack  -- `catch` handleDoesNotExist :: IO ChangeLog+inputChangeLog :: Top -> IO ChangeLog+inputChangeLog (Top top) = readFile (top </> "debian/changelog") >>= return . parseChangeLog . unpack -inputAtomsFromDirectory :: FilePath -> Atoms -> IO Atoms -- .install files, .init files, etc.-inputAtomsFromDirectory debian xs =-    findFiles xs >>= doFiles (debian </> "cabalInstall")+inputAtomsFromDirectory :: Top -> Atoms -> IO Atoms -- .install files, .init files, etc.+inputAtomsFromDirectory top xs =+    findFiles xs >>= doFiles (unTop top </> "debian/cabalInstall")     where       findFiles :: Atoms -> IO Atoms       findFiles xs' =-          getDirectoryContents' debian >>=+          getDirectoryContents' (unTop top </> "debian") >>=           return . (++ ["source/format"]) >>=-          filterM (doesFileExist . (debian </>)) >>=-          foldM (\ xs'' name -> inputAtoms debian name xs'') xs'+          filterM (doesFileExist . ((unTop top </> "debian") </>)) >>=+          foldM (\ xs'' name -> inputAtoms (unTop top </> "debian") name xs'') xs'       doFiles :: FilePath -> Atoms -> IO Atoms       doFiles tmp xs' =           do sums <- getDirectoryContents' tmp `catchIOError` (\ _ -> return [])-             paths <- mapM (\ sum -> getDirectoryContents' (tmp </> sum) >>= return . map (sum </>)) sums >>= return . concat+             paths <- mapM (\ sum -> getDirectoryContents' (tmp </> sum) >>= return . map (sum </>)) sums >>= return . filter ((/= '~') . last) . concat              files <- mapM (readFile . (tmp </>)) paths              foldM (\ xs'' (path, file) -> return $ modL intermediateFiles (Set.insert ("debian/cabalInstall" </> path, file)) xs'') xs' (zip paths files) @@ -238,9 +241,9 @@ readDir :: BinPkgName -> Text -> Atoms -> Atoms readDir p line atoms = modL installDir (insertWith union p (singleton (unpack line))) atoms -inputCabalization :: FilePath -> Atoms -> IO Atoms+inputCabalization :: Top -> Atoms -> IO Atoms inputCabalization top atoms =-    withCurrentDirectory top $ do+    withCurrentDirectory (unTop top) $ do       descPath <- defaultPackageDesc vb       genPkgDesc <- readPackageDescription vb descPath       (compiler', _) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration vb@@ -271,29 +274,8 @@  -- | Try to read the license file specified in the cabal package, -- otherwise return a text representation of the License field.-inputCopyright :: PackageDescription -> IO (Maybe Text)-inputCopyright pkgDesc = (Just <$> readFile' (licenseFile pkgDesc)) `catchIOError` (\ _ -> return Nothing)-{--    where handle _e = return Nothing-              do -- here <- getCurrentDirectory-                 -- hPutStrLn stderr ("Error reading " ++ licenseFile pkgDesc ++ " from " ++ here ++ ": " ++ show _e)-                 return . pack . showLicense . license $ pkgDesc---- | Convert from license to RPM-friendly (now Debian-friendly?)--- description.  The strings are taken from TagsCheck.py in the--- rpmlint distribution.-showLicense :: License -> String-showLicense (Apache _) = "Apache"-showLicense (GPL _) = "GPL"-showLicense (LGPL _) = "LGPL"-showLicense BSD3 = "BSD"-showLicense BSD4 = "BSD-like"-showLicense PublicDomain = "Public Domain"-showLicense AllRightsReserved = "Proprietary"-showLicense OtherLicense = "Non-distributable"-showLicense MIT = "MIT"-showLicense (UnknownLicense _) = "Unknown"--}+inputLicenseFile :: PackageDescription -> IO (Maybe Text)+inputLicenseFile pkgDesc = readFileMaybe (licenseFile pkgDesc)  -- | Try to compute the debian maintainer from the maintainer field of the -- cabal package, or from the value returned by getDebianMaintainer.@@ -301,7 +283,7 @@ inputMaintainer atoms =     debianPackageMaintainer >>= maybe cabalPackageMaintainer (return . Just) >>=                                 maybe getDebianMaintainer (return . Just) >>=-                                maybe lastResortMaintainer (return . Just)+                                return . maybe (Just haskellMaintainer) Just     where       debianPackageMaintainer :: IO (Maybe NameAddr)       debianPackageMaintainer = return (getL Atoms.maintainer atoms)@@ -310,8 +292,6 @@                                           Nothing -> Nothing                                           Just "" -> Nothing                                           Just x -> either (const Nothing) Just (parseMaintainer (takeWhile (\ c -> c /= ',' && c /= '\n') x))-      lastResortMaintainer :: IO (Maybe NameAddr)-      lastResortMaintainer = return (Just haskellMaintainer)  intToVerbosity' :: Int -> Verbosity intToVerbosity' n = fromJust (intToVerbosity (max 0 (min 3 n)))

@@ -26,7 +26,7 @@     pairs :: t -> [(between, around)]      foldTriples :: (around -> between -> around -> r -> r) -> r -> t -> r-    foldTriples f r0 x = snd $ foldl (\ (b1, r) (c, b2) -> (b2, f b1 c b2 r)) (leftmost x, r0) (pairs x)+    foldTriples f r0 x = snd $ foldl (\ (b1, r) (c, b2) -> (b1, f b1 c b2 r)) (leftmost x, r0) (pairs x)      -- Treat the b's as the centers and the c's as the things to their     -- left and right.  Use Maybe to make up for the missing c's at the

@@ -61,16 +61,20 @@              "Set given flags in Cabal conditionals",       Option "" ["maintainer"] (ReqArg (\ maint x -> setL maintainer (either (error ("Invalid maintainer string: " ++ show maint)) Just (parseMaintainer maint)) x) "Maintainer Name <email addr>")              "Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME",-      Option "" ["build-dep"] (ReqArg (\ name atoms -> modL buildDeps (Set.insert (BinPkgName name)) atoms) "Debian binary package name")+      Option "" ["build-dep"] (ReqArg (\ name atoms -> modL buildDeps (Set.insert (Rel (BinPkgName name) Nothing Nothing)) atoms) "Debian binary package name")              "Specify a package to add to the build dependency list for this source package, e.g. '--build-dep libglib2.0-dev'.",-      Option "" ["build-dep-indep"] (ReqArg (\ name atoms -> modL buildDepsIndep (Set.insert (BinPkgName name)) atoms) "Debian binary package name")+      Option "" ["build-dep-indep"] (ReqArg (\ name atoms -> modL buildDepsIndep (Set.insert (Rel (BinPkgName name) Nothing Nothing)) atoms) "Debian binary package name")              "Specify a package to add to the architecture independent build dependency list for this source package, e.g. '--build-dep-indep perl'.",-      Option "" ["dev-dep"] (ReqArg (\ name atoms -> modL extraDevDeps (Set.insert (BinPkgName name)) atoms) "Debian binary package name")+      Option "" ["dev-dep"] (ReqArg (\ name atoms -> modL extraDevDeps (Set.insert (Rel (BinPkgName name) Nothing Nothing)) atoms) "Debian binary package name")              "Specify a package to add to the Depends: list of the -dev package, e.g. '--dev-dep libncurses5-dev'.  It might be good if this implied --build-dep.",       Option "" ["depends"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL depends (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...")              "Generalized --dev-dep - specify pairs A:B of debian binary package names, each A gets a Depends: B",       Option "" ["conflicts"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL conflicts (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...")              "Specify pairs A:B of debian binary package names, each A gets a Conflicts: B.  Note that B can have debian style version relations",+      Option "" ["replaces"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL replaces (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...")+             "Specify pairs A:B of debian binary package names, each A gets a Replaces: B.  Note that B can have debian style version relations",+      Option "" ["provides"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL provides (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...")+             "Specify pairs A:B of debian binary package names, each A gets a Provides: B.  Note that B can have debian style version relations",       Option "" ["map-dep"] (ReqArg (\ pair atoms -> case break (== '=') pair of                                                        (cab, (_ : deb)) -> modL extraLibMap (Map.insertWith Set.union cab (singleton (b deb))) atoms                                                        (_, "") -> error "usage: --map-dep CABALNAME=DEBIANNAME") "CABALNAME=DEBIANNAME")

@@ -21,7 +21,7 @@ import Debian.Debianize.Atoms (Atoms, compiler, dryRun, packageInfo) import Debian.Debianize.Dependencies (cabalDependencies, debDeps, debNameFromType, filterMissing) import Debian.Debianize.Input (inputCabalization)-import Debian.Debianize.Types (PackageInfo(PackageInfo, cabalName, devDeb, profDeb, docDeb), DebType)+import Debian.Debianize.Types (Top(Top), PackageInfo(PackageInfo, cabalName, devDeb, profDeb, docDeb), DebType) import Debian.Debianize.Utility (buildDebVersionMap, DebMap, showDeps, dpkgFileMap, cond, debOfFile, (!), diffFile, replaceFile) import qualified Debian.Relation as D import Distribution.Package (Dependency(..), PackageName(PackageName))@@ -46,7 +46,7 @@           -> DebType  -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc           -> IO () substvars atoms debType =-    do atoms' <- inputCabalization "." atoms+    do atoms' <- inputCabalization (Top ".") atoms        debVersions <- buildDebVersionMap        atoms'' <- libPaths (fromMaybe (error "substvars") $ getL compiler atoms') debVersions atoms'        control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control"

@@ -15,20 +15,21 @@ import Data.Monoid (mconcat, (<>), mempty) import Data.Set as Set (fromList, union, insert, singleton) import qualified Data.Text as T+import Data.Version (Version(Version)) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry) import Debian.Debianize.Debianize (debianization) import Debian.Debianize.Atoms as Atoms     (Atoms, rulesHead, compat, sourceFormat, changelog, control, missingDependencies, revision,      binaryArchitectures, copyright, debVersion, execMap, buildDeps, utilsPackageName, description,-     depends, installData {-, sourcePackageName, install, buildDepsIndep-})+     depends, installData, epochMap {-, sourcePackageName, install, buildDepsIndep-}) import Debian.Debianize.ControlFile as Deb (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..))--- import Debian.Debianize.Debianize (writeDebianization) import Debian.Debianize.Dependencies (getRulesHead) import Debian.Debianize.Files (toFileMap) import Debian.Debianize.Finalize (finalizeDebianization)-import Debian.Debianize.Goodies (defaultAtoms, tightDependencyFixup, doExecutable, doWebsite, doServer, doBackups)+import Debian.Debianize.Goodies (tightDependencyFixup, doExecutable, doWebsite, doServer, doBackups) import Debian.Debianize.Input (inputChangeLog, inputDebianization, inputCabalization)-import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..))+import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), Top(Top))+import Debian.Debianize.VersionSplits (mapCabal, splitCabal) import Debian.Policy (databaseDirectory, StandardsVersion(StandardsVersion), getDebhelperCompatLevel,                       getDebianStandardsVersion, PackagePriority(Extra), PackageArchitectures(All),                       SourceFormat(Native3), Section(..), parseMaintainer)@@ -36,6 +37,7 @@ import Debian.Release (ReleaseName(ReleaseName, relName)) import Debian.Version (buildDebianVersion, parseDebianVersion) import Distribution.License (License(BSD3))+import Distribution.Package (PackageName(PackageName)) import Prelude hiding (log) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((</>))@@ -44,6 +46,17 @@ import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty, text) +-- | A suitable defaultAtoms value for the debian repository.+defaultAtoms :: Atoms+defaultAtoms =+    setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) .+    splitCabal (PackageName "parsec") "parsec2" (Version [3] []) .+    mapCabal (PackageName "parsec") "parsec3" .+    splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) .+    mapCabal (PackageName "QuickCheck") "quickcheck2" .+    mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $+    mempty+ -- | Create a Debianization based on a changelog entry and a license -- value.  Uses the currently installed versions of debhelper and -- debian-policy to set the compatibility levels.@@ -58,11 +71,10 @@     defaultAtoms newDebianization _ _ _ = error "Invalid changelog" -newDebianization' :: Int -> StandardsVersion -> Atoms-newDebianization' level standards =-    setL compat (Just level) $-    modL control (\ x -> x { standardsVersion = Just standards }) $-    defaultAtoms+newDebianization' :: Int -> StandardsVersion -> Atoms -> Atoms+newDebianization' level standards atoms =+    setL compat (Just level) .+    modL control (\ x -> x { standardsVersion = Just standards }) $ atoms  tests :: Test tests = TestLabel "Debianization Tests" (TestList [test1, test2, test3, test4, test5, test6, test7, test8, test9])@@ -146,7 +158,7 @@ test3 :: Test test3 =     TestLabel "test3" $-    TestCase (do deb <- inputDebianization "test-data/haskell-devscripts"+    TestCase (do deb <- inputDebianization (Top "test-data/haskell-devscripts")                  assertEqual "test3" [] (diffDebianizations testDeb2 deb))     where       testDeb2 :: Atoms@@ -201,8 +213,8 @@                                                              , preDepends = []                                                              , breaks = []                                                              , Deb.conflicts = []-                                                             , provides = []-                                                             , replaces = []+                                                             , provides_ = []+                                                             , replaces_ = []                                                              , builtUsing = [] }}]}) $           (newDebianization log 7 (StandardsVersion 3 9 4 Nothing))       log = ChangeLog [Entry { logPackage = "haskell-devscripts"@@ -223,20 +235,24 @@ test4 :: Test test4 =     TestLabel "test4" $-    TestCase (do old <- inputDebianization "test-data/clckwrks-dot-com/output"-                 new <- inputCabalization "test-data/clckwrks-dot-com/input" (newDebianization' 7 (StandardsVersion 3 9 4 Nothing)) >>=-                        debianization "test-data/clckwrks-dot-com/input" .-                          (modL control (\ y -> y {homepage = Just "http://www.clckwrks.com/"}) .-                           setL sourceFormat (Just Native3) .-                           modL missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) .-                           setL revision Nothing .-                           doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production")) .-                           doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups" .-                           fixRules .-                           tight .-                           setL changelog (getL changelog old))+    TestCase (do old <- inputDebianization (Top "test-data/clckwrks-dot-com/output")+                 new <- debianization (Top "test-data/clckwrks-dot-com/input") (customize old) defaultAtoms                  assertEqual "test4" [] (diffDebianizations old (copyFirstLogEntry old new)))     where+      customize :: Atoms -> Atoms -> IO Atoms+      customize old atoms =+          inputCabalization (Top "test-data/clckwrks-dot-com/input") atoms >>=+          return .+          newDebianization' 7 (StandardsVersion 3 9 4 Nothing) .+          modL control (\ y -> y {homepage = Just "http://www.clckwrks.com/"}) .+          setL sourceFormat (Just Native3) .+          modL missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) .+          setL revision Nothing .+          doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production")) .+          doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups" .+          fixRules .+          tight .+          setL changelog (getL changelog old)       -- A log entry gets added when the Debianization is generated,       -- it won't match so drop it for the comparison.       serverNames = map BinPkgName ["clckwrks-dot-com-production"] -- , "clckwrks-dot-com-staging", "clckwrks-dot-com-development"]@@ -316,37 +332,39 @@ test5 :: Test test5 =     TestLabel "test5" $-    TestCase (do old <- inputDebianization "test-data/creativeprompts/output"+    TestCase (do old <- inputDebianization (Top "test-data/creativeprompts/output")                  let standards = fromMaybe (error "test5") (standardsVersion (getL control old))                      level = fromMaybe (error "test5") (getL compat old)-                 new <- debianization "test-data/creativeprompts/input"-                          (setL sourceFormat (Just Native3) $-                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-data") All) $-                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-development") All) $-                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-production") All) $-                           setL utilsPackageName (Just (BinPkgName "creativeprompts-data")) $+                 new <- debianization (Top "test-data/creativeprompts/input")+                          (return .+                           setL sourceFormat (Just Native3) .+                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-data") All) .+                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-development") All) .+                           modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-production") All) .+                           setL utilsPackageName (Just (BinPkgName "creativeprompts-data")) .                            modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-data")                                                     (T.intercalate "\n" [ "creativeprompts.com data files"-                                                               , "  Static data files for creativeprompts.com"])) $+                                                               , "  Static data files for creativeprompts.com"])) .                            modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-production")                                                     (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server"                                                                , "  Production version of the blog server, runs on port"-                                                               , "  9021 with HTML validation turned off." ])) $+                                                               , "  9021 with HTML validation turned off." ])) .                            modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-development")                                                     (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server"                                                                , "  Testing version of the blog server, runs on port"-                                                               , "  8000 with HTML validation turned on." ])) $+                                                               , "  8000 with HTML validation turned on." ])) .                            modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-backups")                                                     (T.intercalate "\n" [ "backup program for creativeprompts.com"                                                                , "  Install this somewhere other than creativeprompts.com to run automated"-                                                               , "  backups of the database."])) $-                           modL Atoms.depends (Map.insertWith union (BinPkgName "creativeprompts-server") (singleton (anyrel (BinPkgName "markdown")))) $-                           modL execMap (Map.insertWith (error "Conflict in execMap") "trhsx" (BinPkgName "haskell-hsx-utils")) $-                           doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups" $-                           doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development")) $-                           doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production")) $-                           setL changelog (getL changelog old) $+                                                               , "  backups of the database."])) .+                           modL Atoms.depends (Map.insertWith union (BinPkgName "creativeprompts-server") (singleton (anyrel (BinPkgName "markdown")))) .+                           modL execMap (Map.insertWith (error "Conflict in execMap") "trhsx" (BinPkgName "haskell-hsx-utils")) .+                           doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups" .+                           doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development")) .+                           doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production")) .+                           setL changelog (getL changelog old) .                            (newDebianization' level standards))+                          defaultAtoms                  assertEqual "test5" [] (diffDebianizations old (copyFirstLogEntry old new)))     where       theSite :: BinPkgName -> Site@@ -417,27 +435,30 @@ test8 :: Test test8 =     TestLabel "test8" $-    TestCase ( do old <- inputDebianization "test-data/artvaluereport-data/output"-                  log <- inputChangeLog "test-data/artvaluereport-data/input/debian"-                  new <- debianization "test-data/artvaluereport-data/input"-                           (modL buildDeps (Set.insert (BinPkgName "haskell-hsx-utils")) $-                            modL control (\ y -> y {homepage = Just "http://artvaluereportonline.com"}) $-                            setL sourceFormat (Just Native3) $-                            setL changelog (Just log) $+    TestCase ( do old <- inputDebianization (Top "test-data/artvaluereport-data/output")+                  log <- inputChangeLog (Top "test-data/artvaluereport-data/input")+                  new <- debianization (Top "test-data/artvaluereport-data/input")+                           (return .+                            modL buildDeps (Set.insert (Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing)) .+                            modL control (\ y -> y {homepage = Just "http://artvaluereportonline.com"}) .+                            setL sourceFormat (Just Native3) .+                            setL changelog (Just log) .                             (newDebianization' 7 (StandardsVersion 3 9 3 Nothing)))+                           defaultAtoms                   assertEqual "test8" [] (diffDebianizations old (copyChangelog old new))              )  test9 :: Test test9 =     TestLabel "test9" $-    TestCase ( do old <- inputDebianization "test-data/alex/output"-                  new <- debianization "test-data/alex/input"-                           (modL buildDeps (Set.insert (BinPkgName "alex")) $-                            doExecutable (BinPkgName "alex") (InstallFile {execName = "alex", destName = "alex", sourceDir = Nothing, destDir = Nothing}) $-                            setL debVersion (Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))) $-                            setL sourceFormat (Just Native3) $-                            modL control (\ y -> y {homepage = Just "http://www.haskell.org/alex/"}) $+    TestCase ( do old <- inputDebianization (Top "test-data/alex/output")+                  new <- debianization (Top "test-data/alex/input")+                           (return .+                            modL buildDeps (Set.insert (Rel (BinPkgName "alex") Nothing Nothing)) .+                            doExecutable (BinPkgName "alex") (InstallFile {execName = "alex", destName = "alex", sourceDir = Nothing, destDir = Nothing}) .+                            setL debVersion (Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))) .+                            setL sourceFormat (Just Native3) .+                            modL control (\ y -> y {homepage = Just "http://www.haskell.org/alex/"}) .                             (\ atoms -> foldr (\ name atoms' -> modL installData (Map.insertWith union (BinPkgName "alex") (singleton (name, name))) atoms')                                               atoms                                               [ "AlexTemplate"@@ -453,8 +474,9 @@                                               , "AlexWrapper-monadUserState-bytestring"                                               , "AlexWrapper-posn"                                               , "AlexWrapper-posn-bytestring"-                                              , "AlexWrapper-strict-bytestring"]) $+                                              , "AlexWrapper-strict-bytestring"]) .                             newDebianization' 7 (StandardsVersion 3 9 3 Nothing))+                           defaultAtoms                   assertEqual "test9" [] (diffDebianizations old (copyFirstLogEntry old new)))  data Change k a

@@ -1,20 +1,21 @@ module Debian.Debianize.Types-    ( PackageInfo(..)+    ( Top(..)+    , PackageInfo(..)     , Site(..)     , Server(..)     , InstallFile(..)-    , VersionSplits(..)     , DebType(..)     , DebAction(..)     ) where -import Data.Version (Version) import Debian.Orphans () import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion) import Distribution.Package (PackageName) import Prelude hiding (init, unlines, log) +newtype Top = Top {unTop :: FilePath}+ data PackageInfo = PackageInfo { cabalName :: PackageName                                , devDeb :: Maybe (BinPkgName, DebianVersion)                                , profDeb :: Maybe (BinPkgName, DebianVersion)@@ -52,13 +53,6 @@       , destDir :: Maybe FilePath -- ^ where to put it, default is usr/bin/<execName>       , destName :: String  -- ^ name to give installed executable       } deriving (Read, Show, Eq, Ord)--data VersionSplits-    = VersionSplits {-        packageName :: PackageName-      , oldestPackage :: PackageName-      , splits :: [(Version, PackageName)] -- Assumed to be in version number order-      } deriving (Eq, Ord, Show)  data DebAction = Usage | Debianize | SubstVar DebType deriving (Read, Show, Eq, Ord) 

@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+module Debian.Debianize.Types.VersionSplits+    ( VersionSplits+    , packageRangesFromVersionSplits+    , makePackage+    , insertSplit+    , doSplits+    , knownVersionSplits+    ) where++import Data.Version (Version(Version), showVersion)+import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples)+import Data.Map as Map (Map, fromList)+import Debian.Orphans ()+import qualified Debian.Relation as D+import Debian.Version (parseDebianVersion)+import Distribution.Package (PackageName(PackageName))+import Distribution.Version (VersionRange, anyVersion, intersectVersionRanges, earlierVersion, orLaterVersion)+import Prelude hiding (init, unlines, log)++-- | Describes a mapping from cabal package name and version to debian+-- package names.  For example, versions of the cabal QuickCheck+-- package less than 2 are mapped to "quickcheck1", while version 2 or+-- greater is mapped to "quickcheck2".+data VersionSplits+    = VersionSplits {+        oldestPackage :: String+      -- ^ The name given to versions older than the oldest split.+      , splits :: [(Version, String)]+      -- ^ Each pair is The version where the split occurs, and the+      -- name to use for versions greater than or equal to that+      -- version.  This list assumed to be in (must be kept in)+      -- ascending version number order.+      } deriving (Eq, Ord, Show)++makePackage :: String -> VersionSplits+makePackage name = VersionSplits {oldestPackage = name, splits = []}++-- | Split the version range and give the older packages a new name.+insertSplit :: Version -> String -> VersionSplits -> VersionSplits+insertSplit ver@(Version _ _) ltname sp@(VersionSplits {}) =+    -- (\ x -> trace ("insertSplit " ++ show (ltname, ver, sp) ++ " -> " ++ show x) x) $+    case splits sp of+      -- This is the oldest split, change oldestPackage and insert a new head pair+      (ver', _) : _ | ver' > ver -> sp {oldestPackage = ltname, splits = (ver, oldestPackage sp) : splits sp}+      [] -> sp {oldestPackage = ltname, splits = [(ver, oldestPackage sp)]}+      -- Not the oldest split, insert it in its proper place.+      _ -> sp {splits = reverse (insert (reverse (splits sp)))}+    where+      -- Insert our new split into the reversed list+      insert ((ver', name') : more) =+          if ver' < ver+          then (ver, name') : (ver', ltname) : more+          else (ver', name') : insert more+      -- ver' is older, change oldestPackage+      insert [] = [(ver, oldestPackage sp)]+      -- ltname = base ++ "-" ++ (show (last ns - 1))++instance Interspersed VersionSplits String Version where+    leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance"+    leftmost (VersionSplits {oldestPackage = p}) = p+    pairs (VersionSplits {splits = xs}) = xs++packageRangesFromVersionSplits :: VersionSplits -> [(String, VersionRange)]+packageRangesFromVersionSplits s =+    foldInverted (\ older dname newer more ->+                      (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more)+                 []+                 s++doSplits :: VersionSplits -> Maybe D.VersionReq -> String+doSplits s version =+    foldTriples' (\ ltName v geName _ ->+                           let split = parseDebianVersion (showVersion v) in+                                case version of+                                  Nothing -> geName+                                  Just (D.SLT v') | v' <= split -> ltName+                                  -- Otherwise use ltName only when the split is below v'+                                  Just (D.EEQ v') | v' < split -> ltName+                                  Just (D.LTE v') | v' < split -> ltName+                                  Just (D.GRE v') | v' < split -> ltName+                                  Just (D.SGR v') | v' < split -> ltName+                                  _ -> geName)+                 (oldestPackage s)+                 s+    where+      foldTriples' :: (String -> Version -> String -> String -> String) -> String -> VersionSplits -> String+      foldTriples' = foldTriples++-- | These are the instances of debian names changing that I know+-- about.  I know they really shouldn't be hard coded.  Send a patch.+-- Note that this inherits the lack of type safety of the mkPkgName+-- function.+knownVersionSplits :: Map PackageName VersionSplits+knownVersionSplits =+    Map.fromList+    [ (PackageName "parsec", VersionSplits {oldestPackage = "parsec2", splits = [(Version [3] [], "parsec3")]})+    , (PackageName "QuickCheck", VersionSplits {oldestPackage = "quickcheck1", splits = [(Version [2] [], "quickcheck2")]})+    -- This just gives a special case cabal to debian name mapping.+    , (PackageName "gtk2hs-buildtools", VersionSplits {oldestPackage = "gtk2hs-buildtools", splits = []}) ]

@@ -16,6 +16,7 @@     , cond     , debOfFile     , readFile'+    , readFileMaybe     , showDeps     , showDeps'     , withCurrentDirectory@@ -27,6 +28,7 @@     , indent     ) where +import Control.Applicative ((<$>)) import Control.Exception as E (catch, try, bracket, IOException) import Control.Monad (when) import Control.Monad.Reader (ReaderT, ask)@@ -48,7 +50,7 @@ import System.Exit(ExitCode(ExitSuccess, ExitFailure)) import System.FilePath ((</>), dropExtension) import System.IO (IOMode (ReadMode), withFile, openFile, hSetBinaryMode)-import System.IO.Error (isDoesNotExistError)+import System.IO.Error (isDoesNotExistError, catchIOError) import System.Process (readProcessWithExitCode, showCommandForUser) import Text.PrettyPrint.ANSI.Leijen (pretty) @@ -151,6 +153,9 @@     do file <- openFile path ReadMode        hSetBinaryMode file True        hGetContents file++readFileMaybe :: FilePath -> IO (Maybe Text)+readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\ _ -> return Nothing)  -- Would like to call pretty instead of D.prettyRelations, but the -- Pretty instance for [a] doesn't work for us.

@@ -0,0 +1,31 @@+module Debian.Debianize.VersionSplits+    ( mapCabal+    , splitCabal+    ) where++import Data.Lens.Lazy (modL)+import Data.Map as Map (alter)+import Data.Version (Version)+import Debian.Debianize.Atoms (Atoms, debianNameMap)+import Debian.Debianize.Types.VersionSplits (VersionSplits, makePackage, insertSplit)+import Distribution.Package (PackageName)++-- | Add a VersionSplits value to 'atoms' that maps the given cabal+-- name 'pname' to the given debian name 'dname'.+mapCabal :: PackageName -> String -> Atoms -> Atoms+mapCabal pname dname atoms =+    modL debianNameMap (Map.alter f pname) atoms+    where+      f :: Maybe VersionSplits -> Maybe VersionSplits+      f Nothing = Just (makePackage dname)+      f (Just sp) = error $ "mapCabal - already mapped: " ++ show sp++-- | Map the versions of 'pname' less than 'ver' to the given debian+-- name 'ltname'.+splitCabal :: PackageName -> String -> Version -> Atoms -> Atoms+splitCabal pname ltname ver atoms =+    modL debianNameMap (Map.alter f pname) atoms+    where+      f :: Maybe VersionSplits -> Maybe VersionSplits+      f Nothing = error $ "splitCabal - not mapped: " ++ show pname+      f (Just sp) = Just (insertSplit ver ltname sp)

@@ -13,7 +13,7 @@ import Debian.Control (Field'(..)) import Debian.Relation (Relation(..), VersionReq(..), ArchitectureReq(..),                         BinPkgName(..), SrcPkgName(..))-import Debian.Version (DebianVersion, prettyDebianVersion, parseDebianVersion)+import Debian.Version (DebianVersion) import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) import Distribution.License (License(..)) import Distribution.PackageDescription (PackageDescription(package), Executable(..))@@ -70,22 +70,8 @@ deriving instance Read SrcPkgName deriving instance Read VersionReq -deriving instance Show ArchitectureReq deriving instance Show ChangeLog deriving instance Show ChangeLogEntry-deriving instance Show Relation-deriving instance Show VersionReq--instance Show DebianVersion where-    show v = "(Debian.Version.parseDebianVersion (" ++ show (show (prettyDebianVersion v)) ++ " :: String))"--instance Read DebianVersion where-    readsPrec _ s =-        case dropPrefix "Debian.Version.parseDebianVersion " s of-          Just s' -> case reads s' :: [(String, String)] of-                       []-> []-                       (v, s'') : _ -> [(parseDebianVersion v, s'')]-          Nothing -> []  dropPrefix :: String -> String -> Maybe String dropPrefix p s = if isPrefixOf p s then Just (drop (length p) s) else Nothing

@@ -10,6 +10,9 @@     , serverLogDirectory     , serverAppLog     , serverAccessLog+    , errorLogBaseName+    , appLogBaseName+    , accessLogBaseName     -- * Installed packages     , debianPackageVersion     , getDebhelperCompatLevel@@ -38,15 +41,16 @@ import Data.Char (toLower, isSpace) import Data.List (groupBy, intercalate) import Data.Generics (Data, Typeable)-import Data.Text (Text, pack, unpack, strip)+import Data.Maybe (mapMaybe) import Data.Monoid ((<>))+import Data.Text (Text, pack, unpack, strip) import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion, parseDebianVersion, version) import System.Environment (getEnvironment) import System.FilePath ((</>)) import System.Process (readProcess) import Text.Parsec (parse)-import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr, address)+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..), address) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text)  databaseDirectory :: BinPkgName -> String@@ -56,20 +60,29 @@ apacheLogDirectory x =  "/var/log/apache2/" ++ show (pretty x)  apacheErrorLog :: BinPkgName -> String-apacheErrorLog x = apacheLogDirectory x </> "error.log"+apacheErrorLog x = apacheLogDirectory x </> errorLogBaseName  apacheAccessLog :: BinPkgName -> String-apacheAccessLog x = apacheLogDirectory x </> "access.log"+apacheAccessLog x = apacheLogDirectory x </> accessLogBaseName  serverLogDirectory :: BinPkgName -> String serverLogDirectory x = "/var/log/" ++ show (pretty x)  serverAppLog :: BinPkgName -> String-serverAppLog x = serverLogDirectory x </> "app.log"+serverAppLog x = serverLogDirectory x </> appLogBaseName  serverAccessLog :: BinPkgName -> String-serverAccessLog x = serverLogDirectory x </> "access.log"+serverAccessLog x = serverLogDirectory x </> accessLogBaseName +appLogBaseName :: String+appLogBaseName = "app.log"++errorLogBaseName :: String+errorLogBaseName = "error.log"++accessLogBaseName :: String+accessLogBaseName = "access.log"+ debianPackageVersion :: String -> IO DebianVersion debianPackageVersion name =     readProcess "dpkg-query" ["--show", "--showformat=${version}", name] "" >>=@@ -215,14 +228,25 @@  haskellMaintainer :: NameAddr haskellMaintainer =-    either error id (parseMaintainer "Debian Haskell Group <pkg-haskell-maintainers@lists.alioth.debian.org>")+    NameAddr { nameAddr_name = Just "Debian Haskell Group"+             , nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}  parseUploaders :: String -> Either String [NameAddr] parseUploaders x =-    either (Left . show) Right (parse address "" ("Names: " ++ map fixWhite x ++ ";"))+    either (Left . show) fixNameAddrs (parse address "" ("Names: " ++ map fixWhite x ++ ";"))     -- either (\ e -> error ("Failure parsing uploader list: " ++ show x ++ " -> " ++ show e)) id $      where       fixWhite c = if isSpace c then ' ' else c+      -- We absoletely need a name.+      fixNameAddrs :: [NameAddr] -> Either String [NameAddr]+      fixNameAddrs xs = case mapMaybe fixNameAddr xs of+                          [] -> Left ("No valid debian maintainers in " ++ show x)+                          xs' -> Right xs'+      fixNameAddr :: NameAddr -> Maybe NameAddr+      fixNameAddr y =+          case nameAddr_name y of+            Nothing -> Nothing+            _ -> Just y  parseMaintainer :: String -> Either String NameAddr parseMaintainer x =

@@ -7,6 +7,7 @@ import Distribution.Version (Version(Version, versionBranch, versionTags), VersionRange, fromVersionIntervals, asVersionIntervals, mkVersionIntervals,                              LowerBound(LowerBound), UpperBound(UpperBound, NoUpperBound), Bound(InclusiveBound, ExclusiveBound)) +-- | This function belongs in Cabal, see http://hackage.haskell.org/trac/hackage/ticket/935. invertVersionRange :: VersionRange -> VersionRange invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals 

@@ -1,7 +0,0 @@-module Main where--import Debian.Debianize.Tests (tests)-import Test.HUnit (runTestTT)--main :: IO ()-main = runTestTT tests >>= putStrLn . show

@@ -1,306 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving #-}-{-# OPTIONS -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}-module Triplets-    ( gzipWithM3-    , gzipWithT3-    , gzipWithA3-    , gzip3-    , gzipQ3-    , gzipBut3-    , gzipButA3-    -- , gzipBut3'-    , extQ2-    , extQ3-    , extT3-    , mkQ3-    , mkQ2-    -- , mkP3-    -- , gzip3F-    , mergeBy-    --, mergeByM-    --, GenericA-    , GB, GM, GA, PB, PM, PA-    ) where--import Prelude hiding (GT)-import Control.Applicative (Applicative(..))-import Control.Applicative.Error (Failing(..))-import Control.Monad (MonadPlus(mzero, mplus))-import Data.Generics (Data, Typeable, Typeable1, toConstr, cast, gcast, gmapAccumQ, gshow, gfoldlAccum,-                      unGT, GenericT, GenericT'(GT), gmapAccumT,-                      unGM, GenericM, GenericM'(GM), gmapAccumM,-                      unGQ, GenericQ, GenericQ'(GQ), gmapQ)-import Data.Maybe (fromMaybe)--instance Monad Failing where-  return = Success-  m >>= f =-      case m of-        (Failure errs) -> (Failure errs)-        (Success a) -> f a-  fail errMsg = Failure [errMsg]--instance MonadPlus Failing where-    mzero = Failure []-    mplus (Failure xs) (Failure ys) = Failure (xs ++ ys)-    mplus success@(Success _) _ = success-    mplus _ success@(Success _) = success-  -deriving instance Typeable1 Failing-deriving instance Data a => Data (Failing a)-deriving instance Read a => Read (Failing a)-deriving instance Eq a => Eq (Failing a)-deriving instance Ord a => Ord (Failing a)--cast' :: (Monad m, Typeable a, Typeable b) => a -> m b-cast' = maybe (fail "cast") return . cast----orElse' = mplus---- As originally defined: Twin map for transformation--{--gzipWithT2 :: GenericQ (GenericT) -> GenericQ (GenericT)-gzipWithT2 f x y = case gmapAccumT perkid funs y of-                   ([], c) -> c-                   _       -> error "gzipWithT2"- where- perkid a d = (tail a, unGT (head a) d)- funs = gmapQ (\k -> GT (f k)) x--}----- As originally defined: Twin map for transformation--{--gzipWithM2 :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)-gzipWithM2 f x y = case gmapAccumM perkid funs y of-                   ([], c) -> c-                   _       -> error "gzipWithM"- where- perkid a d = (tail a, unGM (head a) d)- funs = gmapQ (\k -> GM (f k)) x--}----- As originally defined: generic zip--{--gzip2 ::-   (forall x. Data x => x -> x -> Maybe x)- -> (forall x. Data x => x -> x -> Maybe x)--gzip2 f = gzip2' f'- where- f' :: GenericQ (GenericM Maybe)- f' x y = cast x >>= \x' -> f x' y- gzip2' :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)- gzip2' f x y =-   f x y-   `orElse`-   if toConstr x == toConstr y-     then gzipWithM2 (gzip2' f) x y-     else Nothing--}---- For three args now----type GenericT = forall a. Data a => a -> a---type GenericQ r = forall a. Data a => a -> r---type GenericM m = forall a. Data a => a -> m a--gzipWithT3 ::-   GenericQ (GenericQ (GenericT))- -> GenericQ (GenericQ (GenericT))-gzipWithT3 f x y z =-   case gmapAccumT perkid funs z of-     ([], c) -> c-     _       -> error "gzipWithT3"- where- perkid a d = (tail a, unGT (head a) d)- funs = case gmapAccumQ perkid' funs' y of-          ([], q) -> q-          _       -> error "gzipWithT3"-  where-   perkid' a d = (tail a, unGQ (head a) d)-   funs' = gmapQ (\k -> (GQ (\k' -> GT (f k k')))) x--gzipWithM3 :: Monad m- => GenericQ (GenericQ (GenericM m))- -> GenericQ (GenericQ (GenericM m))-gzipWithM3 f x y z =-    case gmapAccumM perkid funs z of-      ([], c) -> c-      _       -> error "gzipWithM3"-    where-      perkid a d = (tail a, unGM (head a) d)-      funs = case gmapAccumQ perkid' funs' y of-               ([], q) -> q-               _       -> error "gzipWithM3"-          where-            perkid' a d = (tail a, unGQ (head a) d)-            funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x--gzipWithA3 :: forall f. Applicative f => GA f -> GA f-gzipWithA3 f x y z =-    case gmapAccumA perkid funs z of-      ([], c) -> c-      _       -> error "gzipWithA3"-    where-      perkid a d = (tail a, unGM (head a) d)-      funs = case gmapAccumQ perkid' funs' y of-               ([], q) -> q-               _       -> error "gzipWithA3"-          where-            perkid' a d = (tail a, unGQ (head a) d)-            funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x--type GB = GenericQ (GenericQ (GenericQ Bool))--- ^ Generic Bool Query, (Data a, Data b, Data c) => a -> b -> c -> Bool-type GM = MonadPlus m => GenericQ (GenericQ (GenericM m))--- ^ Generic Maybe Query, (Data a, Data b, Data c) => a -> b -> c -> Maybe c-type PB = forall x. Data x => x -> x -> x -> Bool--- ^ Polymorphic Bool Query-type PM = forall m x. (MonadPlus m, Data x) => x -> x -> x -> m x--- ^ Polymorphic Failing Query, forall x. Data x => x -> x -> x -> Failing x-type GA f = GenericQ (GenericQ (GenericM f))--- ^ Generic Applicative Query, forall a. Data a => a -> (forall b. Data b => b -> (forall c. Data c => c -> f c))-type PA f = forall x. Data x => x -> x -> x -> f x--- ^ Polymorphic Applicative Query---- | gmapA with accumulation (untested)--- (Move to Data.Generics.Twins)-gmapAccumA :: forall a d f. (Data d, Applicative f)-           => (forall e. Data e => a -> e -> (a, f e))-           -> a -> d -> (a, f d)-gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0-    where-      k :: forall d e. (Data d) =>-           a -> f (d -> e) -> d -> (a, f e)-      k a c d = let (a',d') = f a d-                    c' = c <*> d'-                in (a', c')-      z :: forall t a f. (Applicative f) =>-           t -> a -> (t, f a)-      z a x = (a, pure x)---- |The purpose of gzip3 is to map a polymorphic (generic) function--- over the "elements" of three instances of a type.  The function--- returns a Maybe value of the same type as the elements passed.  If--- it returns a Just the subtree is not traversed, the returned value--- is used.  If it returns Nothing the subtree is traversed.  This--- traversal may succeed where the top level test failed, resulting in--- a successful zip.  For example, the merge function wouldn't merge--- these three values:---     (1, 1)  (1, 2) (2, 1) -> (?, ?)--- but it could merge the two unzipped triples:---     (1, 1, 2) -> 2---     (1, 2, 1) -> 2---       -> (2, 2)-gzip3 :: PM -> PM-gzip3 f = gzipBut3 f gzipQ3---- |This is the minimal condition for recursing into a value - the--- constructors must all match.-gzipQ3 :: GM-gzipQ3 x y z = -    if and [toConstr x == toConstr y, toConstr y == toConstr z]-    then return undefined-    else fail ("Conflict: x=" ++ gshow x ++ " y=" ++ gshow y ++ " z=" ++ gshow z)---- |This function adds a test to limit the recursion of gzip3.  For--- example, with the merge function mentioned above you might want to--- avoid merging strings character by character:--- ---     gzip3 merge "dim" "kim" "dip" -> Just "kip" (no!)--- --- so you would pass a limiting function to prevent recursing into strings:--- ---     let continue =---          (\ x y z -> extQ3 gzipQ3 x y z) x y z---          where---            stringFail :: String -> String -> String -> Bool---            stringFail _ _ _ = False---     gzipBut3 merge continue "dim" "kim" "dip" -> Nothing--- --- this can also save a lot of time examining all the heads and tails--- of every string.-gzipBut3 :: PM -> GM -> PM-gzipBut3 merge continue x y z =-    gzip3' merge' x y z-    where-      -- If the three elements aren't all the type of f's arguments,-      -- this expression will return Nothing.  Also, the f function-      -- might return Nothing.  In those cases we call gzipWithM3 to-      -- traverse the sub-elements.-      merge' :: GM-      merge' x y z = cast' x >>= \x' -> cast' y >>= \y' -> merge x' y' z-      gzip3' :: GM -> GM-      gzip3' merge x y z =-          merge x y z-         `mplus`-          (continue x y z >> gzipWithM3 (gzip3' merge) x y z)---- | gzipWithA3 plus a continue function to prevent recursion into--- particular types.  (UNTESTED)-gzipButA3 :: forall f. (Applicative f) => PM -> GB -> PA f -> PA f-gzipButA3  merge continue conflict x y z =-    gzip3' x y z-    where-      gzip3' :: GA f-      gzip3' x y z =-          case merge' x y z of-            Just x' -> pure x'-            Nothing ->-                if continue x y z-                then gzipWithA3 gzip3' x y z-                else conflict' x y z-      merge' :: GM-      merge' x y z =-          case (cast x, cast y) of-            (Just x', Just y') -> merge x' y' z-            _ -> fail "type conflict"-      conflict' :: GA f-      conflict' x y z =-          case (cast x, cast y) of-            (Just x', Just y') -> conflict x' y' z-            _ -> error "type conflict"---- | Not to be confused with ext2Q, this extends queries of two--- arguments (rather than queries involving constructors with two type--- parameters.)-extQ2 :: (Typeable a, Typeable b, Typeable d, Typeable e)-      => (a -> b -> r) -> (d -> e -> r) -> a -> b -> r-extQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y')--extQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f)-      => (a -> b -> c -> r) -> (d -> e -> f -> r) -> a -> b -> c -> r-extQ3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> Just (q x' y' z')--mkQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f)-     => r -> (a -> b -> c -> r) -> d -> e -> f -> r-mkQ3 d q x y z = extQ3 (\ _ _ _ -> d) q x y z--extT3 :: (Typeable a, Typeable b)-      => (a -> a -> a -> Maybe a) -> (b -> b -> b -> Maybe b) -> a -> a -> a -> Maybe a-extT3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> gcast (q x' y' z')--mkQ2 :: (Data a, Data b, Data c) => (a -> b -> r) -> (c -> c -> r) -> a -> b -> r-mkQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y')---- |This function implements the f function used to do three way--- merging.  A triplet (original, new1, new2) conflicts if the two--- new values each differ from the original, and from each other.--- Otherwise, the new value that differs from the original is kept, or--- either of the new values if they match.  However, even if the--- values conflict, it still might be possible to do the merge by--- examining the components of the value.  So conflict is typically--- (\ _ _ _ -> Nothing), while eq could be geq, but it could also--- just return false for more complex datatypes that we don't want--- to repeatedly traverse.-mergeBy :: forall a m. MonadPlus m => (a -> a -> a -> m a) -> (a -> a -> Bool) -> a -> a -> a -> m a-mergeBy conflict eq original left right =-    if eq original left then return right-    else if eq original right then return left-         else if eq left right then return left-              else conflict original left right