packages feed

cabal-debian 1.25 → 3.0.3

raw patch · 42 files changed

+6410/−2069 lines, 42 filesdep +Diffdep +HUnitdep +ansi-wl-pprintdep −prettydep ~Cabaldep ~basedep ~debiansetup-changednew-component:exe:cabal-debian-tests

Dependencies added: Diff, HUnit, ansi-wl-pprint, applicative-extras, cabal-debian, data-lens, hsemail, network, pureMD5, syb, text

Dependencies removed: pretty

Dependency ranges changed: Cabal, base, debian

Files

− CabalDebian.hs 
@@ -1,20 +0,0 @@--- |--- Module      :  CabalDebian--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Explanation: Main entry point for generating Debianizations from Cabal data.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.--module Main where--import qualified Distribution.Package.Debian.Main as Debian--main :: IO ()--main = Debian.main
− Distribution/Package/Debian.hs 
@@ -1,752 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections, TypeSynonymInstances #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}---- |--- Module      :  Distribution.Package.Debian--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Explanation: Support for generating Debianization from Cabal data.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.--module Distribution.Package.Debian-    ( debian-    ) where---- import Debug.Trace--import Codec.Binary.UTF8.String (decodeString)-import Control.Arrow (second)-import Control.Exception (SomeException, try, bracket, IOException)-import Control.Monad (when,mplus)-import Control.Monad.Reader (ReaderT(runReaderT), ask)-import Control.Monad.Trans (lift)-import Data.Char (isSpace)-import Data.Either (partitionEithers)-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import qualified Data.Set as Set-import Data.Version (showVersion)-import Debian.Control-import qualified Debian.Relation as D-import Debian.Release (parseReleaseName)-import Debian.Changes (ChangeLogEntry(..), prettyEntry, parseLog)-import Debian.Time (getCurrentLocalRFC822Time)-import Debian.Version (DebianVersion, prettyDebianVersion)-import Debian.Version.String-import System.Cmd (system)-import System.Directory-import System.Exit (ExitCode(..))-import System.FilePath ((</>), dropExtension)-import System.IO (IOMode (ReadMode), hGetContents, hPutStrLn, hSetBinaryMode, openFile, stderr, withFile)-import System.IO.Error (ioeGetFileName, isDoesNotExistError)-import System.Posix.Files (setFileCreationMask)-import System.Environment--import Distribution.Text (display)-import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..), CompilerId(..))-import Distribution.System (Platform(..), buildOS, buildArch)-import Distribution.License (License(..))-import Distribution.Package (Package(..), PackageIdentifier(..), PackageName(..), Dependency(..))-import Distribution.Simple.Program (defaultProgramConfiguration)-import Distribution.Simple.Configure (configCompiler)-import Distribution.Simple.Utils (die, setupMessage)-import Distribution.PackageDescription (GenericPackageDescription(..), PackageDescription(..), exeName)-import Distribution.PackageDescription.Configuration (finalizePackageDescription)---import Distribution.ParseUtils (parseQuoted)-import Distribution.Verbosity (Verbosity)-import Distribution.Package.Debian.Dependencies (PackageType(..), debianExtraPackageName, debianUtilsPackageName, debianSourcePackageName, debianDocPackageName,-                                                 {-DebianBinPackageName,-} debianDevPackageName, debianProfPackageName)-import Distribution.Package.Debian.Relations (versionSplits)-import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..))---import qualified Distribution.Compat.ReadP as ReadP---import Distribution.Text ( Text(parse) )-import Text.PrettyPrint.HughesPJ--import Distribution.Package.Debian.Relations (buildDependencies, docDependencies, allBuildDepends, cabalDependencies)--{--_parsePackageId' :: ReadP.ReadP PackageIdentifier PackageIdentifier-_parsePackageId' = parseQuoted parse ReadP.<++ parse--}--type DebMap = Map.Map D.BinPkgName (Maybe DebianVersion)--buildDebVersionMap :: IO DebMap-buildDebVersionMap =-    readFile "/var/lib/dpkg/status" >>=-    return . either (const []) unControl . parseControl "/var/lib/dpkg/status" >>=-    mapM (\ p -> case (lookupP "Package" p, lookupP "Version" p) of-                   (Just (Field (_, name)), Just (Field (_, version))) ->-                       return (Just (D.BinPkgName (D.PkgName (stripWS name)), Just (parseDebianVersion (stripWS version))))-                   _ -> return Nothing) >>=-    return . Map.fromList . catMaybes--(!) :: DebMap -> D.BinPkgName -> DebianVersion-m ! k = maybe (error ("No version number for " ++ (show . D.prettyBinPkgName $ k) ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)--trim :: String -> String-trim = dropWhile isSpace--simplePackageDescription :: GenericPackageDescription -> Flags-                         -> IO (Compiler, PackageDescription)-simplePackageDescription genPkgDesc flags = do-    (compiler', _) <- {- fchroot (buildRoot flags) -} (configCompiler (Just (rpmCompiler flags)) Nothing Nothing-                                                               defaultProgramConfiguration-                                                               (rpmVerbosity flags))-    let compiler = case (rpmCompilerVersion flags, rpmCompiler flags) of-                     (Just v, ghc) -> compiler' {compilerId = CompilerId ghc v}-                     _ -> compiler'-    --installed <- installedPackages-    case finalizePackageDescription (rpmConfigurationsFlags flags)-          (const True) (Platform buildArch buildOS) (compilerId compiler)-          {- (Nothing :: Maybe PackageIndex) -}-          [] genPkgDesc of-      Left e -> die $ "finalize failed: " ++ show e-      Right (pd, _) -> return (compiler, pd)-    -debian :: GenericPackageDescription	-- ^ info from the .cabal file-       -> Flags				-- ^ command line flags-       -> IO ()--debian genPkgDesc flags =-    case rpmCompiler flags of-      GHC ->-          do (compiler, pkgDesc) <- simplePackageDescription genPkgDesc flags-             let verbose = rpmVerbosity flags-             createDirectoryIfMissing True (debOutputDir flags)-             --lbi <- localBuildInfo pkgDesc flags-             debVersions <- buildDebVersionMap-             cabalPackages <- libPaths compiler debVersions >>= return . Map.fromList . map (\ p -> (cabalName p, p))-             bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> do-               autoreconf verbose pkgDesc-               case debAction flags of-                 SubstVar name ->-                     do control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control"-                        substvars flags pkgDesc compiler debVersions control cabalPackages name-                 Debianize ->-                     debianize True pkgDesc flags compiler (debOutputDir flags)-                 UpdateDebianization ->-                     updateDebianization True pkgDesc flags compiler (debOutputDir flags)-                 Usage ->-                     error "Unexpected debAction: usage"-      c -> die ("the " ++ show c ++ " compiler is not yet supported")--autoreconf :: Verbosity -> PackageDescription -> IO ()--autoreconf verbose pkgDesc = do-    ac <- doesFileExist "configure.ac"-    when ac $ do-        c <- doesFileExist "configure"-        when (not c) $ do-            setupMessage verbose "Running autoreconf" (packageId pkgDesc)-            ret <- system "autoreconf"-            case ret of-              ExitSuccess -> return ()-              ExitFailure n -> die ("autoreconf failed with status " ++ show n)--data PackageInfo = PackageInfo { libDir :: FilePath-                               , cabalName :: String-                               , cabalVersion :: String-                               , devDeb :: Maybe (D.BinPkgName, DebianVersion)-                               , profDeb :: Maybe (D.BinPkgName, DebianVersion)-                               , docDeb :: Maybe (D.BinPkgName, DebianVersion) }  ---- |Each cabal package corresponds to a directory <name>-<version>,--- either in /usr/lib or in /usr/lib/haskell-packages/ghc/lib.--- In that directory is a compiler subdirectory such as ghc-6.8.2.--- In the ghc subdirectory is one or two library files of the form--- libHS<name>-<version>.a and libHS<name>-<version>_p.a.  We can--- determine the debian package names by running dpkg -S on these--- names, or examining the /var/lib/dpkg/info/\*.list files.  From--- these we can determine the source package name, and from that--- the documentation package name.-substvars :: Flags-          -> PackageDescription		-- ^info from the .cabal file-          -> Compiler   		-- ^compiler details-          -> DebMap-          -> Control			-- ^The debian/control file-          -> Map.Map String PackageInfo	-- ^The list of installed cabal packages-          -> DebType			-- ^The type of deb we want to write substvars for-          -> IO ()-substvars flags pkgDesc _compiler _debVersions control cabalPackages debType =-    case (missingBuildDeps, path) of-      -- There should already be a .substvars file produced by dh_haskell_prep,-      -- keep the relations listed there.  They will contain something like this:-      -- libghc-cabal-debian-prof.substvars:-      --    haskell:Depends=ghc-prof (<< 6.8.2-999), ghc-prof (>= 6.8.2), libghc-cabal-debian-dev (= 0.4)-      -- libghc-cabal-debian-dev.substvars:-      --    haskell:Depends=ghc (<< 6.8.2-999), ghc (>= 6.8.2)-      -- haskell-cabal-debian-doc.substvars:-      --    haskell:Depends=ghc-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999)-      ([], Just path') ->-          do old <- try (readFile path') >>= return . either (\ (_ :: SomeException) -> "") id-             let new = addDeps old-             hPutStrLn stderr (if new /= old-                               then ("cabal-debian - Updated " ++ show path' ++ ":\n " ++ old ++ "\n   ->\n " ++ new)-                               else ("cabal-debian - No updates found for " ++ show path'))-             maybe (return ()) (\ _x -> replaceFile path' new) name-      ([], Nothing) -> return ()-      (missing, _) -> -          die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n  " ++ intercalate "\n  " (map (show . D.prettyBinPkgName . fst) missing) ++-               "\nIf this is an obsolete package you may need to withdraw the old versions from the\n" ++-               "upstream repository, and uninstall and purge it from your local system.")-    where-      addDeps old =-          case partition (isPrefixOf "haskell:Depends=") (lines old) of-            ([], other) -> unlines (("haskell:Depends=" ++ showDeps deps) : other)-            (hdeps, more) ->-                case deps of-                  [] -> unlines (hdeps ++ more)-                  _ -> unlines (map (++ (", " ++ showDeps deps)) hdeps ++ more)-      path = fmap (\ (D.BinPkgName (D.PkgName x)) -> "debian/" ++ x ++ ".substvars") name-      name = case debType of Dev -> devDebName; Prof -> profDebName; Doc -> docDebName-      deps = case debType of Dev -> devDeps; Prof -> profDeps; Doc -> docDeps-      -- We must have build dependencies on the profiling and documentation packages-      -- of all the cabal packages.-      missingBuildDeps =-          let requiredDebs =-                  concat (map (\ (Dependency (PackageName name) _) ->-                               case Map.lookup name cabalPackages :: Maybe PackageInfo of-                                 Just info ->-                                     let prof = maybe (devDeb info) Just (profDeb info) in-                                     let doc = docDeb info in-                                     catMaybes [prof, doc]-                                 Nothing -> []) (cabalDependencies flags pkgDesc)) in-          filter (not . (`elem` buildDepNames) . fst) requiredDebs-      -- Make a list of the debian devel packages corresponding to cabal packages-      -- which are build dependencies-      devDeps :: D.Relations-      devDeps =-          catMaybes (map (\ (Dependency (PackageName name) _) ->-                          case Map.lookup name cabalPackages :: Maybe PackageInfo of-                            Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (devDeb package)-                            Nothing -> Nothing) (cabalDependencies flags pkgDesc))-      profDeps :: D.Relations-      profDeps =-          maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) devDebName ++-          catMaybes (map (\ (Dependency (PackageName name) _) ->-                          case Map.lookup name cabalPackages :: Maybe PackageInfo of-                            Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (profDeb package)-                            Nothing -> Nothing) (cabalDependencies flags pkgDesc))-      docDeps :: D.Relations-      docDeps =-          catMaybes (map (\ (Dependency (PackageName name) _) ->-                              case Map.lookup name cabalPackages :: Maybe PackageInfo of-                                Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (docDeb package)-                                Nothing -> Nothing) (cabalDependencies flags pkgDesc))-      buildDepNames :: [D.BinPkgName]-      buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps)-      buildDeps :: D.Relations-      buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi)-      --sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control)))-      devDebName = fmap (D.BinPkgName . D.PkgName) $ listToMaybe (filter (isSuffixOf "-dev") debNames)-      profDebName = fmap (D.BinPkgName . D.PkgName) $ listToMaybe (filter (isSuffixOf "-prof") debNames)-      docDebName = fmap (D.BinPkgName . D.PkgName) $ listToMaybe (filter (isSuffixOf "-doc") debNames)-      debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control))))-      bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control-      bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control---- |Write a file which we might still be reading from in--- order to compute the text argument.-replaceFile :: FilePath -> String -> IO ()-replaceFile path text =-    try (removeFile back) >>= either chk1 return >>		-- This may not exist-    try (renameFile path back) >>= either chk2 return >>	-- This may not exist-    writeFile path text			-- This must succeed-    where-      back = path ++ "~"-      chk1 :: IOException -> IO ()-      chk1 e =-          if ioeGetFileName e == Just back && isDoesNotExistError e-          then return ()-          else ioError e-      chk2 :: IOException -> IO ()-      chk2 e =-          if ioeGetFileName e == Just path && isDoesNotExistError e-          then return ()-          else ioError e--libPaths :: Compiler -> DebMap -> IO [PackageInfo]-libPaths compiler debVersions-    | compilerFlavor compiler == GHC =-        do a <- getDirPaths "/usr/lib"-           b <- getDirPaths "/usr/lib/haskell-packages/ghc/lib"-           -- Build a map from names of installed debs to version numbers-           dpkgFileMap >>= runReaderT (mapM (packageInfo compiler debVersions) (a ++ b)) >>= return . catMaybes-    | True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler)-    where-      getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id--packageInfo :: Compiler ->  DebMap -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe PackageInfo)-packageInfo compiler debVersions (d, f) =-    case parseNameVersion f of-      Nothing -> return Nothing-      Just (p, v) -> lift (doesDirectoryExist (d </> f </> cdir)) >>= cond (return Nothing) (info (d, p, v))-    where-      cdir = display (compilerId compiler)-      info (d, p, v) = -          do dev <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ ".a$")-             prof <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ "_p.a$")-             doc <- debOfFile ("/" ++ p ++ ".haddock$")-             return (Just (PackageInfo { libDir = d-                                       , cabalName = p-                                       , cabalVersion = v-                                       , devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev-                                       , profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof-                                       , docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc }))-      parseNameVersion s =-          case (break (== '-') (reverse s)) of-            (_a, "") -> Nothing-            (a, b) -> Just (reverse (tail b), reverse a) ---- |Create a map from pathname to the names of the packages that contains that pathname.--- We need to make sure we consume all the files, so -dpkgFileMap :: IO (Map.Map FilePath (Set.Set D.BinPkgName))-dpkgFileMap =-    do-      let fp = "/var/lib/dpkg/info"-      names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list")-      let paths = map (fp </>) names-      files <- mapM (strictReadF lines) paths-      return $ Map.fromList $ zip (map dropExtension names) (map (Set.fromList . map (D.BinPkgName . D.PkgName)) $ files)--strictReadF :: (String -> r) -> FilePath -> IO r-strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x))--- strictRead = strictReadF id---- |Given a path, return the name of the package that owns it.-debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe D.BinPkgName)-debOfFile path =-    do mp <- ask-       return $ testPath (Map.lookup path mp)-    where-      -- testPath :: Maybe (Set.Set FilePath) -> Maybe FilePath-      testPath Nothing = Nothing-      testPath (Just s) =-          case Set.size s of-            1 -> Just (Set.findMin s)-            _ -> Nothing--cond :: t -> t -> Bool -> t-cond ifF _ifT False = ifF-cond _ifF ifT True = ifT--debianize :: Bool -> PackageDescription -> Flags -> Compiler -> FilePath -> IO ()-debianize force pkgDesc flags compiler tgtPfx =-    mapM_ removeIfExists ["debian/control"] >>-    updateDebianization force pkgDesc flags compiler tgtPfx--removeFileIfExists :: FilePath -> IO ()-removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x))--removeDirectoryIfExists :: FilePath -> IO ()-removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x))--removeIfExists :: FilePath -> IO ()-removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x--updateDebianization :: Bool                -- ^whether to forcibly create file-                    -> PackageDescription  -- ^info from the .cabal file-                    -> Flags		 -- ^command line flags-                    -> Compiler            -- ^compiler details-                    -> FilePath            -- ^directory in which to create files-                    -> IO ()-updateDebianization _force pkgDesc flags compiler tgtPfx =-    do createDirectoryIfMissing True "debian"-       createDirectoryIfMissing True "debian/source"-       date <- getCurrentLocalRFC822Time-       copyright <- try (readFile' (licenseFile pkgDesc)) >>=-                    return . either (\ (_ :: SomeException) -> showLicense . license $ pkgDesc) id-       debianMaintainer <- getDebianMaintainer flags >>= maybe (error "Missing value for --maintainer") return-       controlUpdate (tgtPfx </> "control") flags compiler debianMaintainer pkgDesc-       changelogUpdate flags (tgtPfx </> "changelog") debianMaintainer pkgDesc date-       replaceFile (tgtPfx </> "rules") (cdbsRules pkgDesc)-       getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True})-       replaceFile (tgtPfx </> "compat") "7" -- should this be hardcoded, or automatically read from /var/lib/dpkg/status?-       replaceFile (tgtPfx </> "copyright") copyright-       replaceFile (tgtPfx </> "source/format") (sourceFormat flags)-       replaceFile (tgtPfx </> "watch") ("version=3\nopts=\"downloadurlmangle=s|archive/([\\w\\d_-]+)/([\\d\\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\\\nfilenamemangle=s|(.*)/$|" ++ pkgname ++ "-$1.tar.gz|\" \\\n    http://hackage.haskell.org/packages/archive/" ++ pkgname ++ " \\\n    ([\\d\\.]*\\d)/\n")-       -- The dev postinst and prerm files are generated by haskell-devscripts via cdbs.-       return ()-    where-        PackageName pkgname = pkgName . package $ pkgDesc--readFile' :: FilePath -> IO String-readFile' path-  = do-    file <- openFile path ReadMode-    hSetBinaryMode file True-    hGetContents file--{--Create a debian maintainer field from the environment variables:--  DEBFULLNAME (preferred) or NAME-  DEBEMAIL (preferred) or EMAIL--More work could be done to match dch, but this is sufficient for-now. Here is what the man page for dch has to say:-- If the environment variable DEBFULLNAME is set, this will be used for- the maintainer full name; if not, then NAME will be checked.  If the- environment variable DEBEMAIL is set, this will be used for the email- address.  If this variable has the form "name <email>", then the- maintainer name will also be taken from here if neither DEBFULLNAME- nor NAME is set.  If this variable is not set, the same test is- performed on the environment variable EMAIL.  Next, if the full name- has still not been determined, then use getpwuid(3) to determine the- name from the pass‐word file.  If this fails, use the previous- changelog entry.  For the email address, if it has not been set from- DEBEMAIL or EMAIL, then look in /etc/mailname, then attempt to build- it from the username and FQDN, otherwise use the email address in the- previous changelog entry.  In other words, it’s a good idea to set- DEBEMAIL and DEBFULLNAME when using this script.---}-getDebianMaintainer :: Flags -> IO (Maybe String)-getDebianMaintainer flags =-    case debMaintainer flags of-      Nothing -> envMaintainer-      maint -> return maint-    where-      envMaintainer :: IO (Maybe String)-      envMaintainer =-          do env <- map (second decodeString) `fmap` getEnvironment-             return $ do fullname <- lookup "DEBFULLNAME" env `mplus` lookup "NAME" env-                         email    <- lookup "DEBEMAIL" env `mplus` lookup "EMAIL" env-                         return (fullname ++ " <" ++ email ++ ">")--cdbsRules :: PackageDescription -> String-cdbsRules pkgDesc =-    unlines (intercalate [""] ([header, execs, comments] {- ++ devrules ++ profrules -} ))-    where-      header =-          ["#!/usr/bin/make -f",-           "",-           "DEB_CABAL_PACKAGE = " ++ (show (D.prettyBinPkgName (debianExtraPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc))))))))),-           "",-           "include /usr/share/cdbs/1/rules/debhelper.mk",-           "include /usr/share/cdbs/1/class/hlibrary.mk"]-      execs =-          case map exeName (executables pkgDesc) ++ dataFiles pkgDesc of-            [] -> []-{--            [e] ->-                let exe = exeName e-                    src = "dist-ghc/build/" ++ exe ++ "/" ++ exe-                    dst = "debian/" ++ exeDeb e ++ "/usr/bin/" ++ exe in-                [ -- Magic rule required to get binaries to build in packages that have no libraries-                  "build/" ++ exeDeb e ++ ":: build-ghc-stamp"-                , "binary-fixup/" ++ exeDeb e ++ "::"-                , "\tinstall -m 755 -s -D " ++ src ++ " " ++ dst ++ " || true"]--}-            _ ->-                [ -- Magic rule required to get binaries to build in packages that have no libraries-                  "build/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ ":: build-ghc-stamp"-                , "binary-fixup/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ "::" ] ++-                map (\ exe ->-                         let src = "dist-ghc/build/" ++ exe ++ "/" ++ exe-                             dst = "debian/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ "/usr/bin/" ++ exe in-                         "\tinstall -m 755 -s -D " ++ src ++ " " ++ dst ++ " || true") (map exeName (executables pkgDesc)) ++-                map (\ file ->-                         let dst = "debian" </> (show . D.prettyBinPkgName $ utilsDeb) </> "usr/share" </> libDir </> file in-                         "\tinstall -m 644 -D " ++ file ++ " " ++ dst ++ " || true") (dataFiles pkgDesc)-      comments =-          ["# How to install an extra file into the documentation package",-           "#binary-fixup/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "::",-           "#\techo \"Some informative text\" > debian/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "/usr/share/doc/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "/AnExtraDocFile"]-      p = pkgName . package $ pkgDesc-      v = pkgVersion . package $ pkgDesc-      libDir = unPackageName p ++ "-" ++ showVersion v-      docDeb = debianDocPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc))))))-      utilsDeb = debianUtilsPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc))))))-      --exeDeb e = debianExtraPackageName (PackageName (exeName e)) Nothing--list :: b -> ([a] -> b) -> [a] -> b-list d f l = case l of [] -> d; _ -> f l--controlUpdate :: FilePath -> Flags -> Compiler -> String -> PackageDescription -> IO ()-controlUpdate path flags compiler debianMaintainer pkgDesc =-    try (readFile path) >>=-    either (\ (_ :: SomeException) -> writeFile path (show newCtl)) (\ s -> writeFile (path ++ ".new") $! show (merge newCtl (oldCtl s)))-    where-      newCtl = control flags compiler debianMaintainer pkgDesc-      oldCtl s = either (const (Control [])) id (parseControl "debian/control" s)-      merge (Control new) (Control old) =-          case (new, old) of-            (_newSource : _new', []) -> Control new-            (newSource : new', oldSource : old') ->-                Control (mergeParagraphs newSource oldSource : mergeOther new' old')-      -- Merge a list of binary package paragraphs-      mergeOther new old =-          map mergePackages allNames-          where-            mergePackages name =-                case (findPackage name new, findPackage name old) of-                  (Just x, Nothing) -> x-                  (Nothing, Just x) -> x-                  (Just x, Just y) -> mergeParagraphs x y-            findPackage name paras = listToMaybe (filter (hasName name) paras)-                where hasName name para = lookupP "Package" para == Just name-            allNames = newNames ++ (oldNames \\ newNames)-            newNames = catMaybes $ map (lookupP "Package") new-            oldNames = catMaybes $ map (lookupP "Package") old--mergeParagraphs :: Paragraph' String -> Paragraph' String -> Paragraph' String-mergeParagraphs new@(Paragraph newFields) old@(Paragraph oldFields) =-    Paragraph (map mergeField fieldNames)-    where-      fieldNames = map fieldName oldFields ++ (map fieldName newFields \\ map fieldName oldFields)-      fieldName (Field (name, _)) = name-      mergeField :: String -> Field-      mergeField name =-          case (lookupP name new, lookupP name old) of-            (Just (Field (_, x)), Nothing) -> Field (name, x)-            (Nothing, Just (Field (_, x))) -> Field (name, x)-            (Just (Field (_, x)), Just (Field (_, y))) -> Field (name, mergeValues name x y)-            _ -> error $ "Internal error"-      mergeValues :: String -> String -> String -> String-      mergeValues "Build-Depends" x y =-          " " ++ (showDeps' "Build-Depends:" $ mergeDeps (parseDeps x) (parseDeps y))-      mergeValues "Depends" x y =-          " " ++ (showDeps' "Depends:" $ mergeDeps (parseDeps x) (parseDeps y))-      mergeValues _ x _ = x-      parseDeps s = either (error . show) id (D.parseRelations s)--mergeDeps :: D.Relations -> D.Relations -> D.Relations-mergeDeps x y = -    -- foldr :: (a -> b -> b) -> b -> [a] -> b-    nub $ foldr insertDep x y-    where-      insertDep :: [D.Relation] -> D.Relations -> D.Relations-      insertDep ys xss =-          case depPackageNames ys of-            [name] -> case break (\ xs -> depPackageNames xs == [name]) xss of-                        (a, b : c) -> a ++ [b, ys] ++ c-                        (a, []) -> a ++ [ys]-            _ -> xss ++ [ys]-      depPackageNames xs = nub (map depPackageName xs)-      depPackageName (D.Rel x _ _) = x--control :: Flags -> Compiler -> String -> PackageDescription -> Control-control flags compiler debianMaintainer pkgDesc =-    -- trace ("allBuildDepends " ++ show flags ++ " -> " ++ show (allBuildDepends flags pkgDesc)) $-    Control {unControl =-             ([sourceSpec] ++-              develLibrarySpecs ++-              profileLibrarySpecs ++ -              docLibrarySpecs ++-              (case map exeName (executables pkgDesc) ++ dataFiles pkgDesc of-                 [] -> []-                 -- [e] -> [utilsSpec (debianName Extra (PackageName (exeName e)) Nothing)]-                 _ -> [utilsSpec (show . D.prettyBinPkgName $ debianUtilsPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))]))}-    where-      --buildDepsIndep = ""-      sourceSpec =-          Paragraph-          ([Field ("Source", " " ++ (show . D.prettySrcPkgName $ debianSourcePackageName versionSplits (pkgName . package $ pkgDesc) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))),-            Field ("Priority", " " ++ "extra"),-            Field ("Section", " " ++ "haskell"),-            Field ("Maintainer", " " ++ debianMaintainer),-            Field ("Build-Depends", " " ++ showDeps' "Build-Depends:" (debianBuildDeps ++ map rel (buildDeps flags))),-            Field ("Build-Depends-Indep", " " ++ showDeps' "Build-Depends-Indep:" debianBuildDepsIndep),-            --Field ("Build-Depends-Indep", " " ++ buildDepsIndep),-            Field ("Standards-Version", " " ++ "3.9.3"),-            Field ("Homepage",-                   " " ++-                   if homepage pkgDesc == ""-                   then "http://hackage.haskell.org/package/" ++-                        unPackageName (pkgName $ package pkgDesc)-                   else homepage pkgDesc)])-      rel x = [D.Rel (D.BinPkgName (D.PkgName x)) Nothing Nothing]-      utilsSpec p =-          Paragraph-          [Field ("Package", " " ++ p),-           Field ("Architecture", " " ++ "any"),-           Field ("Section", " " ++ "misc"),-           -- No telling what the dependencies of an executable might-           -- be.  The developer will have to fill them in-           Field ("Depends", " " ++ showDeps [[D.Rel (D.BinPkgName (D.PkgName "${shlibs:Depends}")) Nothing Nothing], -                                              [D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing],-                                              [D.Rel (D.BinPkgName (D.PkgName "${misc:Depends}")) Nothing Nothing]]),-           Field ("Description", " " ++ maybe debianDescription (const executableDescription) (library pkgDesc))]-      develLibrarySpecs = if isJust (library pkgDesc) then [librarySpec "any" Development debianDevPackageName] else []-      profileLibrarySpecs = if debLibProf flags && isJust  (library pkgDesc) then [librarySpec "any" Profiling debianProfPackageName] else []-      docLibrarySpecs = if isJust (library pkgDesc) && rpmHaddock flags then [docSpecsParagraph] else []-      docSpecsParagraph =-          Paragraph-          [Field ("Package", " " ++ (show . D.prettyBinPkgName $ debianDocPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))),-           Field ("Architecture", " " ++ "all"),-           Field ("Section", " " ++ "doc"),-           Field ("Depends", " " ++ showDeps' "Depends:" [[D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing],-                                                           [D.Rel (D.BinPkgName (D.PkgName "${misc:Depends}")) Nothing Nothing]]),-           Field ("Recommends", " " ++ "${haskell:Recommends}"),-           Field ("Suggests", " " ++ "${haskell:Suggests}"),-           Field ("Description", " " ++ libraryDescription Documentation)]-      librarySpec arch typ debianName =-          Paragraph-          [Field ("Package", " " ++ (show . D.prettyBinPkgName $ debianName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))),-           Field ("Architecture", " " ++ arch),-           Field ("Depends", " " ++ showDeps' "Depends:" (-                     (if typ == Development-                      then [[D.Rel (D.BinPkgName (D.PkgName "${shlibs:Depends}")) Nothing Nothing]] ++ map (\ x -> [D.Rel (D.BinPkgName (D.PkgName x)) Nothing Nothing]) (extraDevDeps flags)-                      else []) ++-                     [[D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing],-                      [D.Rel (D.BinPkgName (D.PkgName "${misc:Depends}")) Nothing Nothing]])),-           Field ("Recommends", " " ++ "${haskell:Recommends}"),-           Field ("Suggests", " " ++ "${haskell:Suggests}"),-           Field ("Provides", " " ++ "${haskell:Provides}"),-           Field ("Description", " " ++ libraryDescription typ)]-      -- The haskell-cdbs package contains the hlibrary.mk file with-      -- the rules for building haskell packages.-      debianBuildDeps :: D.Relations-      debianBuildDeps = -          nub $-          [[D.Rel (D.BinPkgName (D.PkgName "debhelper")) (Just (D.GRE (parseDebianVersion "7.0"))) Nothing],-           [D.Rel (D.BinPkgName (D.PkgName "haskell-devscripts")) (Just (D.GRE (parseDebianVersion "0.8"))) Nothing],-           [D.Rel (D.BinPkgName (D.PkgName "cdbs")) Nothing Nothing],-           [D.Rel (D.BinPkgName (D.PkgName "ghc")) Nothing Nothing]] ++-          (if debLibProf flags then [[D.Rel (D.BinPkgName (D.PkgName "ghc-prof")) Nothing Nothing]] else []) ++-          (concat . map (buildDependencies flags compiler) . allBuildDepends flags $ pkgDesc)-      debianBuildDepsIndep :: D.Relations-      debianBuildDepsIndep =-          nub $-          [[D.Rel (D.BinPkgName (D.PkgName "ghc-doc")) Nothing Nothing]] ++-          (concat . map (docDependencies flags compiler) . allBuildDepends flags $ pkgDesc)-      debianDescription = -          (unwords . words . synopsis $ pkgDesc) ++-          case description pkgDesc of-            "" -> ""-            text ->-                let text' = text ++ "\n" ++-                            list "" ("\n Author: " ++) (author pkgDesc) ++-                            list "" ("\n Upstream-Maintainer: " ++) (maintainer pkgDesc) ++-                            list "" ("\n Url: " ++) (pkgUrl pkgDesc) in-                "\n " ++ (trim . intercalate "\n " . map addDot . lines $ text')-      addDot line = if all (flip elem " \t") line then "." else line-      executableDescription = " " ++ "An executable built with the " ++ display (package pkgDesc) ++ " library."-      libraryDescription Profiling = debianDescription ++ "\n .\n This package contains the libraries compiled with profiling enabled."-      libraryDescription Development = debianDescription ++ "\n .\n This package contains the normal library files."-      libraryDescription Documentation = debianDescription ++ "\n .\n This package contains the documentation files."-      libraryDescription x = error $ "Unexpected library package name suffix: " ++ show x--showDeps :: [[D.Relation]] -> String-showDeps xss = intercalate ", " (map (intercalate " | " . map (show . D.prettyRelation)) xss)--{--showDeps' :: [a] -> [[D.Relation]] -> String-showDeps' prefix xss =-    intercalate (",\n " ++ prefix') (map (intercalate " | " . map (show . D.prettyRelation)) xss)-    where prefix' = map (\ _ -> ' ') prefix--}--showDeps' :: [a] -> [[D.Relation]] -> String-showDeps' prefix xss =-    intercalate ("\n" ++ prefix' ++ " , ") (map (intercalate " | " . map (show . D.prettyRelation)) xss)-    where prefix' = map (\ _ -> ' ') prefix--changelogUpdate :: Flags -> FilePath -> String -> PackageDescription -> String -> IO ()-changelogUpdate flags path debianMaintainer pkgDesc date =-    read >>= replace-    where-      read :: IO ([[String]], [ChangeLogEntry])-      read = try (readFile path) >>= return . either (\ (e :: SomeException) -> ([[show e]], [])) (partitionEithers . parseLog)-      replace :: ([[String]], [ChangeLogEntry]) -> IO ()-      replace (errs, entries) =-          do when (not (null errs)) (hPutStrLn stderr (intercalate "\n " ("Errors reading changelog:" : concat errs)))-             let entries' = dropWhile (\ entry -> logVersion entry >= logVersion log) entries-             replaceFile path (intercalate "\n" (map (render . prettyEntry) (log : entries')))-      log = changelog flags debianMaintainer pkgDesc date--{--changelog :: Flags -> String -> PackageDescription -> String -> String-changelog flags debianMaintainer pkgDesc date =-    render . prettyEntry $ changelog' flags debianMaintainer pkgDesc date--}--changelog :: Flags -> String -> PackageDescription -> String -> ChangeLogEntry-changelog flags debianMaintainer pkgDesc date =-    Entry { logPackage = (show . D.prettySrcPkgName $ debianSourcePackageName versionSplits (pkgName . package $ pkgDesc) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))-          , logVersion = updateOriginal f $ debianVersionNumber pkgDesc-          , logDists = [parseReleaseName "unstable"]-          , logUrgency = "low"-          , logComments = "  * Debianization generated by cabal-debian\n\n"-          , logWho = debianMaintainer-          , logDate = date }-    where-      f s = maybe (g s) (\ d -> if older d s then error ("Version from --deb-version (" ++ show d ++ ") is older than hackage version (" ++ show s ++ "), maybe you need to unpin this package?") else d) (debVersion flags)-      g s = maybe "" (\ n -> show n ++ ":") (Map.lookup (pkgName (package pkgDesc)) (epochMap flags)) ++ s ++ revision flags-      older debv cabv = parseDebianVersion debv < parseDebianVersion cabv--updateOriginal :: (String -> String) -> DebianVersion -> DebianVersion---updateOriginal f (DebianVersion str dv) = DebianVersion (f str) dv-updateOriginal f v = parseDebianVersion . f . show . prettyDebianVersion $ v--unPackageName :: PackageName -> String-unPackageName (PackageName s) = s----debianDevelPackageName' (Dependency (PackageName name) _) = debianDevelPackageName name---- debianPackageName prefix name suffix = prefix ++ (map toLower name) ++ suffix--debianVersionNumber :: PackageDescription -> DebianVersion-debianVersionNumber pkgDesc = parseDebianVersion . showVersion . pkgVersion . package $ pkgDesc---- generated with:--- apt-cache show ghc \---   | grep ^Provides: \---   | cut -d\  -f2----   | sed 's/, /\n/g' \---   | grep libghc- \---   | cut -d- -f2- \---   | grep dev$ \---   | sed 's/-dev//;s/$/",/;s/^/"/'--{--base :: Set String-base-  = Data.Set.fromList-    ["array",-      "base",-      "bin-package-db",-      "bytestring",-      "cabal",-      "containers",-      "directory",-      "extensible-exceptions",-      "filepath",-      "ghc-binary",-      "ghc-prim",-      "haskell2010",-      "haskell98",-      "hpc",-      "integer-gmp",-      "old-locale",-      "old-time",-      "pretty",-      "process",-      "random",-      "rts",-      "template-haskell",-      "time",-      "unix"]--}---- | Convert from license to RPM-friendly description.  The strings are--- taken from TagsCheck.py in the rpmlint distribution.--showLicense :: License -> String-showLicense (GPL _) = "GPL"-showLicense (LGPL _) = "LGPL"-showLicense BSD3 = "BSD"-showLicense BSD4 = "BSD-like"-showLicense PublicDomain = "Public Domain"-showLicense AllRightsReserved = "Proprietary"-showLicense OtherLicense = "Non-distributable"
− Distribution/Package/Debian/Bundled.hs 
@@ -1,323 +0,0 @@--- |--- Module      :  Distribution.Package.Debian.Bundled--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Determine whether a specific version of a Haskell package is--- bundled with into this particular version of the given compiler.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.-{-# LANGUAGE StandaloneDeriving #-}-module Distribution.Package.Debian.Bundled-    ( ghcBuiltIn-    ) where--import qualified Data.Map as Map-import Data.Set (fromList, member)-import Data.Version (Version(..))-import Debian.Relation.ByteString()-import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-})-import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-})-import System.Exit (ExitCode(..))--type Bundled = (CompilerFlavor, Version, [PackageIdentifier])---- |Return a list of built in packages for the compiler in an environment.--- ghcBuiltIns :: FilePath -> IO [PackageIdentifier]--- ghcBuiltIns root =---     fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>=---     return . map parsePackageIdentifier . words . unpack . fst . collectStdout---     where---       parsePackageIdentifier s =---           let (v', n') = break (== '-') (reverse s)---               (v, n) = (reverse (tail n'), reverse v') in---           PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) [])--ghcBuiltIns :: Compiler -> Bundled-ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) =-    case Map.lookup compilerVersion-             (Map.fromList [ (Version [7,4,1] [], (GHC, Version [7,4,1] [], ghc741BuiltIns))-                           , (Version [7,4,0,20111219] [], (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns))-                           , (Version [7,4,0,20120108] [], (GHC, Version [7,4,0,20120108] [], ghc740BuiltIns))-                           , (Version [7,2,2] [], (GHC, Version [7,2,2] [], ghc721BuiltIns))-                           , (Version [7,2,1] [], (GHC, Version [7,2,1] [], ghc721BuiltIns))-                           , (Version [7,0,4] [], (GHC, Version [7,0,4] [], ghc701BuiltIns))-                           , (Version [7,0,3] [], (GHC, Version [7,0,3] [], ghc701BuiltIns))-                           , (Version [7,0,1] [], (GHC, Version [7,0,1] [], ghc701BuiltIns))-                           , (Version [6,8,3] [], (GHC, Version [6,8,3] [], ghc683BuiltIns))-                           , (Version [6,8,2] [], (GHC, Version [6,8,2] [], ghc682BuiltIns))-                           , (Version [6,8,1] [], (GHC, Version [6,8,1] [], ghc681BuiltIns))-                           , (Version [6,6,1] [], (GHC, Version [6,6,1] [], ghc661BuiltIns))-                           , (Version [6,6] [], (GHC, Version [6,6] [], ghc66BuiltIns)) ]) of-      Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion-      Just x -> x--ghcBuiltIn :: Compiler -> PackageName -> Bool-ghcBuiltIn compiler package =-    Data.Set.member-        package-        (Data.Set.fromList-             (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -}-                  (_, _, xs) = ghcBuiltIns compiler in map pkgName xs))--v :: String -> [Int] -> PackageIdentifier-v n x = PackageIdentifier (PackageName n) (Version x [])---- | Packages bundled with 7.4.0.20111219-2.-ghc741BuiltIns :: [PackageIdentifier]-ghc741BuiltIns = [-    v "Cabal" [1,14,0],-    v "array" [0,4,0,0],-    v "base" [4,5,0,0],-    v "bin-package-db" [0,0,0,0],-    v "binary" [0,5,1,0],-    v "bytestring" [0,9,2,1],-    v "containers" [0,4,2,1],-    v "deepseq" [1,3,0,0],-    v "directory" [1,1,0,2],-    v "extensible-exceptions" [0,1,1,4],-    v "filepath" [1,3,0,0],-    v "ghc" [7,4,1],-    v "ghc-prim" [0,2,0,0],-    v "haskell2010" [1,1,0,1],-    v "haskell98" [2,0,0,1],-    v "hoopl" [3,8,7,2],-    v "hpc" [0,5,1,1],-    v "integer-gmp" [0,4,0,0],-    v "old-locale" [1,0,0,4],-    v "old-time" [1,1,0,0],-    v "pretty" [1,1,1,0],-    v "process" [1,1,0,1], -    v "rts" [1,0],-    v "template-haskell" [2,7,0,0],-    v "time" [1,4],-    v "unix" [2,5,1,0] ]---- | Packages bundled with 7.4.0.20111219-2.-ghc740BuiltIns :: [PackageIdentifier]-ghc740BuiltIns = [-    v "Cabal" [1,14,0],-    v "array" [0,4,0,0],-    v "base" [4,5,0,0],-    v "bin-package-db" [0,0,0,0],-    v "binary" [0,5,1,0],-    v "bytestring" [0,9,2,1],-    v "containers" [0,4,2,1],-    v "deepseq" [1,3,0,0],-    v "directory" [1,1,0,2],-    v "extensible-exceptions" [0,1,1,4],-    v "filepath" [1,3,0,0],-    v "ghc" [7,4,0,20111219],-    v "ghc-prim" [0,2,0,0],-    v "haskell2010" [1,1,0,1],-    v "haskell98" [2,0,0,1],-    v "hoopl" [3,8,7,2],-    v "hpc" [0,5,1,1],-    v "integer-gmp" [0,4,0,0],-    v "old-locale" [1,0,0,4],-    v "old-time" [1,1,0,0],-    v "pretty" [1,1,1,0],-    v "process" [1,1,0,1], -    v "rts" [1,0],-    v "template-haskell" [2,7,0,0],-    v "time" [1,4],-    v "unix" [2,5,1,0] ]--ghc721BuiltIns :: [PackageIdentifier]-ghc721BuiltIns = [-    v "Cabal" [1,12,0],-    v "array" [0,3,0,3],-    v "base" [4,4,0,0],-    v "bin-package-db" [0,0,0,0],-    v "binary" [0,5,0,2],-    v "bytestring" [0,9,2,0],-    v "containers" [0,4,1,0],-    v "directory" [1,1,0,1],-    v "extensible-exceptions" [0,1,1,3],-    v "filepath" [1,2,0,1],-    v "ghc" [7,2,1],-    -- ghc-binary renamed to binary-    v "ghc-prim" [0,2,0,0],-    v "haskell2010" [1,1,0,0],-    v "haskell98" [2,0,0,0],-    v "hoopl" [3,8,7,1], -- new-    v "hpc" [0,5,1,0],-    v "integer-gmp" [0,3,0,0],-    v "old-locale" [1,0,0,3],-    v "old-time" [1,0,0,7],-    v "pretty" [1,1,0,0],-    v "process" [1,1,0,0], -    -- random removed-    v "rts" [1,0],-    v "template-haskell" [2,6,0,0],-    v "time" [1,2,0,5],-    v "unix" [2,5,0,0] ]--ghc701BuiltIns :: [PackageIdentifier]-ghc701BuiltIns = [-    v "Cabal" [1,10,0,0],-    v "array" [0,3,0,2],-    v "base" [4,3,0,0],-    v "bin-package-db" [0,0,0,0],-    v "bytestring" [0,9,1,8],-    v "containers" [0,4,0,0],-    v "directory" [1,1,0,0],-    v "extensible-exceptions" [0,1,1,2],-    v "filepath" [1,2,0,0],-    v "ghc" [7,0,1],-    v "ghc-binary" [0,5,0,2],-    v "ghc-prim" [0,2,0,0],-    v "haskell2010" [1,0,0,0],-    v "haskell98" [1,1,0,0],-    v "hpc" [0,5,0,6],-    v "integer-gmp" [0,2,0,2],-    v "old-locale" [1,0,0,2],-    v "old-time" [1,0,0,6],-    v "pretty" [1,0,1,2],-    v "process" [1,0,1,4],-    v "random" [1,0,0,3],-    v "rts" [1,0],-    v "template-haskell" [2,5,0,0],-    v "time" [1,2,0,3],-    v "unix" [2,4,1,0]-  ]--ghc683BuiltIns :: [PackageIdentifier]-ghc683BuiltIns = ghc682BuiltIns--ghc682BuiltIns :: [PackageIdentifier]-ghc682BuiltIns = [-    v "Cabal" [1,2,3,0],-    v "array" [0,1,0,0],-    v "base" [3,0,1,0],-    v "bytestring" [0,9,0,1],-    v "containers" [0,1,0,1],-    v "directory" [1,0,0,0],-    v "filepath" [1,1,0,0],-    v "ghc" [6,8,2,0],-    v "haskell98" [1,0,1,0],-    v "hpc" [0,5,0,0],-    v "old-locale" [1,0,0,0],-    v "old-time" [1,0,0,0],-    v "packedstring" [0,1,0,0],-    v "pretty" [1,0,0,0],-    v "process" [1,0,0,0],-    v "random" [1,0,0,0],-    v "readline" [1,0,1,0],-    v "template-haskell" [2,2,0,0],-    v "unix" [2,3,0,0]-    ]--ghc681BuiltIns :: [PackageIdentifier]-ghc681BuiltIns = [-    v "base" [3,0,0,0],-    v "Cabal" [1,2,2,0],-    v "GLUT" [2,1,1,1],-    v "HGL" [3,2,0,0],-    v "HUnit" [1,2,0,0],-    v "OpenAL" [1,3,1,1],-    v "OpenGL" [2,2,1,1],-    v "QuickCheck" [1,1,0,0],-    v "X11" [1,2,3,1],-    v "array" [0,1,0,0],-    v "bytestring" [0,9,0,1],-    v "cgi" [3001,1,5,1],-    v "containers" [0,1,0,0],-    v "directory" [1,0,0,0],-    v "fgl" [5,4,1,1],-    v "filepatch" [1,1,0,0],-    v "ghc" [6,8,1,0],-    v "haskell-src" [1,0,1,1],-    v "haskell98" [1,0,1,0],-    v "hpc" [0,5,0,0],-    v "html" [1,0,1,1],-    v "mtl" [1,1,0,0],-    v "network" [2,1,0,0],-    v "old-locale" [1,0,0,0],-    v "old-time" [1,0,0,0],-    v "packedstring" [0,1,0,0],-    v "parallel" [1,0,0,0],-    v "parsec" [2,1,0,0],-    v "pretty" [1,0,0,0],-    v "process" [1,0,0,0],-    v "random" [1,0,0,0],-    v "readline" [1,0,1,0],-    v "regex-base" [0,72,0,1],-    v "regex-compat" [0,71,0,1],-    v "regex-posix" [0,72,0,1],-    v "stm" [2,1,1,0],-    v "template-haskell" [2,2,0,0],-    v "time" [1,1,2,0],-    v "unix" [2,2,0,0],-    v "xhtml" [3000,0,2,1]-    ]--ghc661BuiltIns :: [PackageIdentifier]-ghc661BuiltIns = [-    v "base" [2,1,1],-    v "Cabal" [1,1,6,2],-    v "cgi" [3001,1,1],-    v "fgl" [5,4,1],-    v "filepath" [1,0],-    v "ghc" [6,6,1],-    v "GLUT" [2,1,1],-    v "haskell98" [1,0],-    v "haskell-src" [1,0,1],-    v "HGL" [3,1,1],-    v "html" [1,0,1],-    v "HUnit" [1,1,1],-    v "mtl" [1,0,1],-    v "network" [2,0,1],-    v "OpenAL" [1,3,1],-    v "OpenGL" [2,2,1],-    v "parsec" [2,0],-    v "QuickCheck" [1,0,1],-    v "readline" [1,0],-    v "regex-base" [0,72],-    v "regex-compat" [0,71],-    v "regex-posix" [0,71],-    v "rts" [1,0],-    v "stm" [2,0],-    v "template-haskell" [2,1],-    v "time" [1,1,1],-    v "unix" [2,1],-    v "X11" [1,2,1],-    v "xhtml" [3000,0,2]-    ]--ghc66BuiltIns :: [PackageIdentifier]-ghc66BuiltIns = [-    v "base" [2,0],-    v "Cabal" [1,1,6],-    v "cgi" [2006,9,6],-    v "fgl" [5,2],-    v "ghc" [6,6],-    v "GLUT" [2,0],-    v "haskell98" [1,0],-    v "haskell-src" [1,0],-    v "HGL" [3,1],-    v "html" [1,0],-    v "HTTP" [2006,7,7],-    v "HUnit" [1,1],-    v "mtl" [1,0],-    v "network" [2,0],-    v "OpenAL" [1,3],-    v "OpenGL" [2,1],-    v "parsec" [2,0],-    v "QuickCheck" [1,0],-    v "readline" [1,0],-    v "regex-base" [0,71],-    v "regex-compat" [0,71],-    v "regex-posix" [0,71],-    v "rts" [1,0],-    v "stm" [2,0],-    v "template-haskell" [2,0],-    v "time" [1,0],-    v "unix" [1,0],-    v "X11" [1,1],-    v "xhtml" [2006,9,13]-    ]
− Distribution/Package/Debian/Dependencies.hs 
@@ -1,327 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving #-}-{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}-module Distribution.Package.Debian.Dependencies-    ( PackageType(..)-    , VersionSplits(..)-    , dependencies-    , mkPkgName-    , invertVersionRange-    -- , debianName-    , debianSourcePackageName-    , DebianBinPackageName-    , debianDevPackageName-    , debianProfPackageName-    , debianDocPackageName-    , debianExtraPackageName-    , debianUtilsPackageName-    ) where--import Data.Char (toLower)-import Data.Function (on)-import Data.List (intersperse, minimumBy)-import qualified Data.Map as Map-import Data.Maybe (catMaybes)-import Data.Version (showVersion)-import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(PkgName), VersionReq(..), SrcPkgName(..))-import qualified Debian.Relation as D-import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion)-import Distribution.Package (PackageName(PackageName))-import Distribution.Package.Debian.Bundled (ghcBuiltIn)-import Distribution.Package.Debian.Interspersed (Interspersed(..))-import Distribution.Package.Debian.Setup (Flags(..))-import Distribution.Simple.Compiler (Compiler(..))-import Distribution.Version (Version(..), VersionRange(..), anyVersion, foldVersionRange', intersectVersionRanges, unionVersionRanges,-                             laterVersion, orLaterVersion, earlierVersion, orEarlierVersion, fromVersionIntervals, toVersionIntervals, withinVersion,-                             isNoVersion, asVersionIntervals, mkVersionIntervals, LowerBound(..), UpperBound(..), Bound(..))-import Text.PrettyPrint (Doc, text, hcat , (<>), empty)--data PackageType = Source | Development | Profiling | Documentation | Utilities | Extra deriving (Eq, Show)--data VersionSplits-    = VersionSplits {-        packageName :: PackageName-      , oldestPackage :: BinPkgName-      , splits :: [(Version, BinPkgName)] -- Assumed to be in version number order-      }--instance Interspersed VersionSplits BinPkgName Version where-    leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance"-    leftmost (VersionSplits {oldestPackage = p}) = p-    pairs (VersionSplits {splits = xs}) = xs---- | Turn a cabal dependency into debian dependencies.  The result--- needs to correspond to a single debian package to be installed,--- so we will return just an OrRelation.-dependencies :: Flags -> Compiler -> (PackageType -> [VersionSplits]) -> PackageType -> Either BinPkgName PackageName -> VersionRange -> Relations-dependencies flags compiler versionSplits typ (Left name) cabalRange = [[D.Rel name Nothing Nothing]]-dependencies flags compiler versionSplits typ (Right name@(PackageName string)) cabalRange =-    map doBundled $ convert' (canonical (Or (catMaybes (map convert alts))))-    where--      -- Compute a list of alternative debian dependencies for-      -- satisfying a cabal dependency.  The only caveat is that-      -- 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 versionSplits typ) of-               -- If there are no splits for this package just return the single dependency for the package-               Nothing -> [(mkPkgName string typ, cabalRange')]-               -- If there are splits create a list of (debian package name, VersionRange) pairs-               Just splits -> packageRangesFromVersionSplits splits--      convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation)-      convert (dname, range) =-          if isNoVersion range'''-          then Nothing-          else Just $-               foldVersionRange'-                 (Rel (D.Rel dname Nothing Nothing))-                 (\ v -> Rel (D.Rel dname (Just (D.EEQ (dv v))) Nothing))-                 (\ v -> Rel (D.Rel dname (Just (D.SGR (dv v))) Nothing))-                 (\ v -> Rel (D.Rel dname (Just (D.SLT (dv v))) Nothing))-                 (\ v -> Rel (D.Rel dname (Just (D.GRE (dv v))) Nothing))-                 (\ v -> Rel (D.Rel dname (Just (D.LTE (dv v))) Nothing))-                 (\ x y -> And [Rel (D.Rel dname (Just (D.GRE (dv x))) Nothing), Rel (D.Rel dname (Just (D.SLT (dv y))) Nothing)])-                 (\ x y -> Or [x, y])-                 (\ x y -> And [x, y])-                 id-                 range'''-          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-            range'' = canon (unionVersionRanges range' (invertVersionRange range))-            -- Restrict the range to the versions specified for this debian package-            range' = intersectVersionRanges cabalRange' range-            -- When we see a cabal equals dependency we need to turn it into-            -- a wildcard because the resulting debian version numbers have-            -- various suffixes added.-      cabalRange' =-          foldVersionRange'-            anyVersion-            withinVersion  -- <- Here we are turning equals into wildcard-            laterVersion-            earlierVersion-            orLaterVersion-            orEarlierVersion-            (\ lb ub -> intersectVersionRanges (orLaterVersion lb) (earlierVersion ub))-            unionVersionRanges-            intersectVersionRanges-            id-            cabalRange-      -- Convert a cabal version to a debian version, adding an epoch number if requested-      dv v = parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (epochMap flags)) ++ showVersion v)-      simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2]-      -- Simplify a VersionRange-      canon = fromVersionIntervals . toVersionIntervals--      -- If a package is bundled with the compiler we make the-      -- compiler a substitute for that package.  If we were to-      -- specify the virtual package (e.g. libghc-base-dev) we would-      -- have to make sure not to specify a version number.-      doBundled :: [D.Relation] -> [D.Relation]-      doBundled rels | ghcBuiltIn compiler name = rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing]-      doBundled rels = rels--      compilerPackageName Documentation = D.BinPkgName (D.PkgName "ghc-doc")-      compilerPackageName Profiling = D.BinPkgName (D.PkgName "ghc-prof")-      compilerPackageName Development = D.BinPkgName (D.PkgName "ghc")-      compilerPackageName _ = D.BinPkgName (D.PkgName "ghc") -- whatevs--data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel {unRel :: a} deriving Show---- | The intent of this class is to be similar to Show, but only one--- way, with no corresponding Read class.  To put something in a--- pretty printing class implies that there is only one way to pretty--- print it, which is not an assumption made by Text.PrettyPrint.  But--- in practice this is often good enough.-class Pretty x where-    pretty :: x -> Doc---- | return and of ors of rel-canonical :: Rels a -> Rels a-canonical (Rel rel) = And [Or [Rel rel]]-canonical (And rels) = And $ concatMap (unAnd . canonical) rels-canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels--convert' :: Rels a -> [[a]]-convert' = map (map unRel . unOr) . unAnd . canonical--packageSplits :: (PackageType -> [VersionSplits]) -> PackageType -> Map.Map PackageName VersionSplits-packageSplits versionSplits typ =-    foldr (\ splits mp -> Map.insertWith multipleSplitsError (packageName splits) splits mp)-          Map.empty-          (versionSplits typ)-    where-      multipleSplitsError (VersionSplits {packageName = PackageName p}) _s2 =-          error ("Multiple splits for package " ++ show p)--packageRangesFromVersionSplits :: VersionSplits -> [(BinPkgName, VersionRange)]-packageRangesFromVersionSplits splits =-    foldInverted (\ older dname newer more ->-                      (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more)-                 []-                 splits---- | Build a debian package name from a cabal package name and a--- debian package type.-mkPkgName :: String -> PackageType -> BinPkgName-mkPkgName base typ =-    BinPkgName . PkgName $ prefix typ ++ map toLower base ++ suffix typ-    where-      suffix Source = ""-      suffix Documentation = "-doc"-      suffix Development = "-dev"-      suffix Profiling = "-prof"-      suffix Utilities = "-utils"-      suffix Extra = ""--      prefix Source = "haskell-"-      prefix Documentation = "libghc-"-      prefix Development = "libghc-"-      prefix Profiling = "libghc-"-      prefix Utilities = "haskell-"-      prefix Extra = ""--instance Pretty VersionRange where-    pretty range =-        foldVersionRange'-          (text "*")-          (\ v -> text "=" <> pretty v)-          (\ v -> text ">" <> pretty v)-          (\ v -> text "<" <> pretty v)-          (\ v -> text ">=" <> pretty v)-          (\ v -> text "<=" <> pretty v)-          (\ x _ -> text "=" <> pretty x <> text ".*") -- not exactly right-          (\ x y -> text "(" <> x <> text " || " <> y <> text ")")-          (\ x y -> text "(" <> x <> text " && " <> y <> text ")")-          (\ x -> text "(" <> x <> text ")")-          range--instance Pretty Version where-    pretty = text . showVersion--instance Pretty a => Pretty [a] where-    pretty xs = text "[" <> hcat (intersperse (text ", ") (map pretty xs)) <> text "]"--instance (Pretty a, Pretty b) => Pretty (a, b) where-    pretty (a, b) = text "(" <> pretty a <> text ", " <> pretty b <> text ")"--instance Pretty D.BinPkgName where-    pretty (D.BinPkgName p) = text "deb:" <> (pretty p)--instance Pretty D.PkgName where-    pretty (D.PkgName p) = text p--instance Pretty D.Relation where-    pretty (D.Rel name ver arch) =-        pretty name <> maybe empty pretty ver <> maybe empty pretty arch--instance Pretty D.VersionReq where-    pretty (D.EEQ v) = text "=" <> pretty v-    pretty (D.SLT v) = text "<" <> pretty v-    pretty (D.LTE v) = text "<=" <> pretty v-    pretty (D.GRE v) = text ">=" <> pretty v-    pretty (D.SGR v) = text ">" <> pretty v--instance Pretty D.ArchitectureReq where-    pretty (D.ArchOnly ss) = text "[" <> hcat (intersperse (text ",") (map text ss)) <> text "]"-    pretty (D.ArchExcept ss) = text "[!" <> hcat (intersperse (text ",") (map text ss)) <> text "]"--instance Pretty DebianVersion where-    pretty = text . show--instance Show D.Relation where-    show = show . pretty-instance Show D.ArchitectureReq where-    show = show . pretty--invertVersionRange :: VersionRange -> VersionRange-invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals--invertVersionIntervals :: [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)]-invertVersionIntervals xs =-    case xs of-      [] -> [(lb0, NoUpperBound)]-      ((LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound, ub) : more) ->-          invertVersionIntervals' ub more-      ((lb, ub) : more) ->-          (lb0, invertLowerBound lb) : invertVersionIntervals' ub more-    where-      invertVersionIntervals' :: UpperBound -> [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)]-      invertVersionIntervals' NoUpperBound [] = []-      invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]-      invertVersionIntervals' ub0 [(lb, NoUpperBound)] = [(invertUpperBound ub0, invertLowerBound lb)]-      invertVersionIntervals' ub0 ((lb, ub1) : more) = (invertUpperBound ub0, invertLowerBound lb) : invertVersionIntervals' ub1 more--      invertLowerBound :: LowerBound -> UpperBound-      invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)--      invertUpperBound :: UpperBound -> LowerBound-      invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)-      invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"--      invertBound :: Bound -> Bound-      invertBound ExclusiveBound = InclusiveBound-      invertBound InclusiveBound = ExclusiveBound--      lb0 :: LowerBound-      lb0 = LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound--deriving instance Show VersionReq-instance Show DebianVersion where-    show = show . prettyDebianVersion--debianSourcePackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> SrcPkgName-debianSourcePackageName versionSplits name version = SrcPkgName (D.unBinPkgName (debianName Source versionSplits name version))--debianDevPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianDevPackageName versionSplits name version = debianName Development versionSplits name version--debianProfPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianProfPackageName versionSplits name version = debianName Profiling versionSplits name version--debianDocPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianDocPackageName versionSplits name version = debianName Documentation versionSplits name version--type DebianBinPackageName = PackageName -> Maybe VersionReq -> BinPkgName--debianExtraPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianExtraPackageName versionSplits name version = debianName Extra versionSplits name version--debianUtilsPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianUtilsPackageName versionSplits name version = debianName Utilities versionSplits name version---- | Return the basename of the debian package for a given version--- relation.  If the version split happens at v, this will return the--- ltName is < v and the geName if the relation is >= v.  It also handles--- a special case for the name of the haskell-src-exts package.-debianName :: PackageType -> (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName-debianName typ versionSplits pname@(PackageName name) version =-    case filter (\ x -> pname == packageName x) (versionSplits typ) of-      [] -> def-      [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 (SLT v') | v' <= split -> ltName-                                  -- Otherwise use ltName only when the split is below v'-                                  Just (EEQ v') | v' < split -> ltName-                                  Just (LTE v') | v' < split -> ltName-                                  Just (GRE v') | v' < split -> ltName-                                  Just (SGR v') | v' < split -> ltName-                                  _ -> geName)-                       def-                       splits-      _ -> error $ "Multiple splits for cabal package " ++ name-    where-      foldTriples' :: (BinPkgName -> Version -> BinPkgName -> BinPkgName -> BinPkgName) -> BinPkgName -> VersionSplits -> BinPkgName-      foldTriples' = foldTriples-      def = mkPkgName (map fixChar name) typ--fixChar :: Char -> Char-fixChar '_' = '-'-fixChar c = toLower c
− Distribution/Package/Debian/Interspersed.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, TypeSynonymInstances #-}-{-# OPTIONS_GHC -Wall -Werror #-}-module Distribution.Package.Debian.Interspersed-    ( Interspersed(..)-    ) where--import Debug.Trace---- | A class of Bs insterspersed with Cs.  Minimum implementation is a--- method to return the leftmost B, and another to return the--- following (C,B) pairs.  Its unfortunate to require lists in the--- implementation, a fold function would be better (though I find--- implementing such folds to be a pain in the you-know-what.)--- --- The class provides implementations of three folds, each of which--- exposes slightly different views of the data.-class Interspersed t around between | t -> around, t -> between where-    leftmost :: t -> around-    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)--    -- 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-    -- ends.-    foldInverted :: (Maybe between -> around -> Maybe between -> r -> r) -> r -> t -> r-    foldInverted f r0 x =-        (\ (bn, an, r) -> f bn an Nothing r) $-           foldl g (Nothing, leftmost x, r0) (pairs x)-        where-          g (b1, a1, r) (b2, a2) = (Just b2, a2, f b1 a1 (Just b2) r)--    foldArounds :: (around -> around -> r -> r) -> r -> t -> r-    foldArounds f r0 x = snd $ foldl (\ (a1, r) (_, a2) -> (a2, f a1 a2 r)) (leftmost x, r0) (pairs x)--    foldBetweens :: (between -> r -> r) -> r -> t -> r-    foldBetweens f r0 x = foldl (\ r (b, _) -> (f b r)) r0 (pairs x)---- | An example-data Splits = Splits Double [(String, Double)] deriving Show--instance Interspersed Splits Double String where-    leftmost (Splits x _) = x-    pairs (Splits _ x) = x--_splits :: Splits-_splits = Splits 1.0 [("between 1 and 2", 2.0), ("between 2 and 3", 3.0)]--_test1 :: ()-_test1 = foldTriples (\ l s r () -> trace ("l=" ++ show l ++ " s=" ++ show s ++ " r=" ++ show r) ()) () _splits--_test2 :: ()-_test2 = foldInverted (\ sl f sr () -> trace ("sl=" ++ show sl ++ " f=" ++ show f ++ " sr=" ++ show sr) ()) () _splits
− Distribution/Package/Debian/Main.hs 
@@ -1,28 +0,0 @@--- |--- Module      :  Distribution.Package.Debian.Main--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Explanation: Main entry point for Debianizer of Cabal packages.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.--module Distribution.Package.Debian.Main where--import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Package.Debian (debian)-import Distribution.Package.Debian.Setup (Flags (..), parseArgs)-import Distribution.Simple.Utils (defaultPackageDesc)-import System.Environment (getArgs)--main :: IO ()--main = do opts <- getArgs >>= parseArgs-          let verbosity = rpmVerbosity opts-          descPath <- defaultPackageDesc verbosity-          pkgDesc <- readPackageDescription verbosity descPath-          debian pkgDesc opts
− Distribution/Package/Debian/Relations.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, PackageImports, ScopedTypeVariables,-             StandaloneDeriving, TupleSections, TypeSynonymInstances #-}-{-# OPTIONS -Wall -fno-warn-orphans #-}---- |--- Module      :  Distribution.Package.Debian--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Explanation: Support for generating Debianization from Cabal data.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.--module Distribution.Package.Debian.Relations-    ( allBuildDepends-    , buildDependencies-    , docDependencies-    , cabalDependencies-    , versionSplits-    ) where--import Data.Char (isSpace)-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Version (Version(Version))-import qualified Debian.Relation as D-import Distribution.Simple.Compiler (Compiler(..))-import Distribution.Package (PackageName(..), Dependency(..))-import Distribution.PackageDescription (PackageDescription(..),-                                        allBuildInfo, buildTools, pkgconfigDepends,-                                        extraLibs)-import Distribution.Version (anyVersion)-import Distribution.Package.Debian.Setup (Flags(..))-import Distribution.Package.Debian.Dependencies (PackageType(..), VersionSplits(..), dependencies, mkPkgName)-import System.Exit (ExitCode(ExitSuccess))-import System.IO.Unsafe (unsafePerformIO)-import System.Process (readProcessWithExitCode)--cabalDependencies :: Flags -> PackageDescription -> [Dependency]-cabalDependencies flags pkgDesc = catMaybes $ map unboxDependency $ allBuildDepends flags pkgDesc---- |Debian packages don't have per binary package build dependencies,--- so we just gather them all up here.-allBuildDepends :: Flags -> PackageDescription -> [Dependency_]-allBuildDepends flags pkgDesc =-    nub $ map BuildDepends (buildDepends pkgDesc) ++-          concat (map (map BuildTools . buildTools) (allBuildInfo pkgDesc) ++-                  map-                    (map PkgConfigDepends . pkgconfigDepends)-                    (allBuildInfo pkgDesc) ++-                  map (map ExtraLibs . (fixDeps . extraLibs)) (allBuildInfo pkgDesc))-    where-      fixDeps :: [String] -> [D.BinPkgName]-      fixDeps xs = concatMap (\ cab -> fromMaybe [D.BinPkgName (D.PkgName ("lib" ++ cab ++ "-dev"))] (Map.lookup cab (depMap flags))) xs---- The build dependencies for a package include the profiling--- libraries and the documentation packages, used for creating cross--- references.-buildDependencies :: Flags -> Compiler -> Dependency_ -> D.Relations-buildDependencies flags compiler (BuildDepends (Dependency name ranges)) =-    dependencies flags compiler versionSplits Development (Right name) ranges ++ dependencies flags compiler versionSplits Profiling (Right name) ranges-buildDependencies flags compiler dep@(ExtraLibs _) =-    concat (map (\ x -> dependencies flags compiler versionSplits Extra (Left x) anyVersion) $ adapt flags dep)-buildDependencies flags compiler dep =-    case unboxDependency dep of-      Just (Dependency _name ranges) ->-          concat (map (\ x -> dependencies flags compiler versionSplits Extra (Left x) ranges) $ adapt flags dep)-      Nothing ->-          []--adapt :: Flags -> Dependency_ -> [D.BinPkgName]-adapt flags (PkgConfigDepends (Dependency (PackageName pkg) _)) =-    maybe (aptFile pkg) (: []) (Map.lookup pkg (execMap flags))-adapt flags (BuildTools (Dependency (PackageName pkg) _)) =-    maybe (aptFile pkg) (: []) (Map.lookup pkg (execMap flags))-adapt _flags (ExtraLibs x) = [x]-{--    maybe (error ("No mapping from library " ++ x ++ " to debian binary package name"))-              (map (\ s -> PackageName ("lib" ++ s ++ "-dev"))) (Map.lookup x (depMap flags))--}-adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [D.BinPkgName (D.PkgName pkg)]---- |There are two reasons this may not work, or may work--- incorrectly: (1) the build environment may be a different--- distribution than the parent environment (the environment the--- autobuilder was run from), so the packages in that--- environment might have different names, and (2) the package--- we are looking for may not be installed in the parent--- environment.-aptFile :: String -> [D.BinPkgName] -- Maybe would probably be more correct-aptFile pkg =-    unsafePerformIO $-          do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] ""-             return $ case ret of-                        (ExitSuccess, out, _) -> [D.BinPkgName (D.PkgName (takeWhile (not . isSpace) out))]-                        _ -> []---- The documentation dependencies for a package include the documentation--- package for any libraries which are build dependencies, so we have access--- to all the cross references.-docDependencies :: Flags -> Compiler -> Dependency_ -> D.Relations-docDependencies flags compiler (BuildDepends (Dependency name ranges)) =-    dependencies flags compiler versionSplits Documentation (Right name) ranges-docDependencies _ _ _ = []--data Dependency_-  = BuildDepends Dependency-      | BuildTools Dependency-      | PkgConfigDepends Dependency-      | ExtraLibs D.BinPkgName-    deriving (Eq, Show)--unboxDependency :: Dependency_ -> Maybe Dependency-unboxDependency (BuildDepends d) = Just d-unboxDependency (BuildTools d) = Just d-unboxDependency (PkgConfigDepends d) = Just d-unboxDependency (ExtraLibs _) = Nothing -- Dependency (PackageName d) anyVersion---- | These are the instances of debian names changing that we know about.-versionSplits :: PackageType -> [VersionSplits]-versionSplits typ =-    [ VersionSplits {-        packageName = PackageName "parsec"-      , oldestPackage = mkPkgName "parsec2" typ-      , splits = [(Version [3] [], mkPkgName "parsec3" typ)] }-    , VersionSplits {-        packageName = PackageName "QuickCheck"-      , oldestPackage = mkPkgName "quickcheck1" typ-      , splits = [(Version [2] [], mkPkgName "quickcheck2" typ)] }-    ]
− Distribution/Package/Debian/Setup.hs 
@@ -1,220 +0,0 @@--- |--- Module      :  Distribution.Package.Debian.Setup--- Copyright   :  David Fox 2008------ Maintainer  :  David Fox <dsf@seereason.com>--- Stability   :  alpha--- Portability :  portable------ Explanation: Command line option processing for building RPM--- packages.---- This software may be used and distributed according to the terms of--- the GNU General Public License, incorporated herein by reference.--module Distribution.Package.Debian.Setup (-      Flags(..)-    , DebAction(..)-    , DebType(..)-    , parseArgs-    ) where--import Control.Monad (when)-import Data.Char (toLower, isDigit, ord)-import qualified Data.Map as Map-import Data.Version (Version, parseVersion)-import Debian.Relation (PkgName(..), BinPkgName(..))-import Distribution.Compiler (CompilerFlavor(..))-import Distribution.ReadE (readEOrFail)-import Distribution.PackageDescription (FlagName(..))-import Distribution.Package (PackageName(..))-import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)-import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..),-                              usageInfo, getOpt')-import System.Environment (getProgName)-import System.Exit (exitWith, ExitCode (..))-import System.IO (Handle, hPutStrLn, stderr, stdout)-import Text.ParserCombinators.ReadP (readP_to_S)--data Flags = Flags-    {-      rpmPrefix :: FilePath-    , rpmCompiler :: CompilerFlavor-    , rpmCompilerVersion :: Maybe Version-    , rpmConfigurationsFlags :: [(FlagName, Bool)]-    , rpmHaddock :: Bool-    , rpmHelp :: Bool-    , debLibProf :: Bool-    , rpmName :: Maybe String-    , rpmOptimisation :: Bool-    , rpmRelease :: Maybe String-    , rpmSplitObjs :: Bool-    , debOutputDir :: FilePath-    , buildRoot :: FilePath-    , rpmVerbosity :: Verbosity-    , rpmVersion :: Maybe String-    , debMaintainer :: Maybe String-    , debAction :: DebAction-    , buildDeps :: [String]-    , extraDevDeps :: [String]-    -- , debName :: Maybe String-    , debVersion :: Maybe String-    , depMap :: Map.Map String [BinPkgName]-    , epochMap :: Map.Map PackageName Int-    , revision :: String-    , execMap :: Map.Map String BinPkgName-    , omitLTDeps :: Bool-    , sourceFormat :: String-    }-    deriving (Eq, Show)--data DebType = Dev| Prof | Doc deriving (Eq, Read, Show)--data DebAction = Usage | Debianize | SubstVar DebType | UpdateDebianization deriving (Eq, Show)--emptyFlags :: Flags--emptyFlags = Flags-    {-      rpmPrefix = "/usr/lib/haskell-packages/ghc6"-    , rpmCompiler = GHC-    , rpmCompilerVersion = Nothing-    , rpmConfigurationsFlags = []-    , rpmHaddock = True-    , rpmHelp = False-    , debLibProf = True-    , rpmName = Nothing-    , rpmOptimisation = True-    , rpmRelease = Nothing-    , rpmSplitObjs = True-    , debOutputDir = "./debian"-    , buildRoot = "/"-    , rpmVerbosity = normal-    , rpmVersion = Nothing-    , debMaintainer = Nothing-    , debAction = Usage-    , buildDeps = []-    , extraDevDeps = []-    , depMap = Map.empty-    , epochMap = Map.empty-    -- , debName = Nothing-    , debVersion = Nothing-    , revision = "-1~hackage1"-    , execMap = Map.empty-    , omitLTDeps = False-    , sourceFormat = "3.0 (native)"-    }--options :: [OptDescr (Flags -> Flags)]--options =-    [-      Option "" ["prefix"] (ReqArg (\ path x -> x { rpmPrefix = path }) "PATH")-             "Pass this prefix if we need to configure the package",-      Option "" ["ghc"] (NoArg (\x -> x { rpmCompiler = GHC }))-             "Compile with GHC",-      Option "" ["hugs"] (NoArg (\x -> x { rpmCompiler = Hugs }))-             "Compile with Hugs",-      Option "" ["jhc"] (NoArg (\x -> x { rpmCompiler = JHC }))-             "Compile with JHC",-      Option "" ["nhc"] (NoArg (\x -> x { rpmCompiler = NHC }))-             "Compile with NHC",-      Option "h?" ["help"] (NoArg (\x -> x { rpmHelp = True }))-             "Show this help text",-      Option "" ["ghc-version"] (ReqArg (\ ver x -> x { rpmCompilerVersion = Just (last (map fst (readP_to_S parseVersion ver)))}) "VERSION")-             "Version of GHC in build environment",-      Option "" ["name"] (ReqArg (\name x -> x { rpmName = Just name }) "NAME")-             "Override the default package name",-      Option "" ["disable-haddock"] (NoArg (\x -> x { rpmHaddock = False }))-             "Don't generate API docs",-      Option "" ["disable-library-profiling"] (NoArg (\x -> x { debLibProf = False }))-             "Don't generate profiling libraries",-      Option "" ["disable-optimization"] (NoArg (\x -> x { rpmOptimisation = False }))-             "Don't generate optimised code",-      Option "" ["disable-split-objs"] (NoArg (\x -> x { rpmSplitObjs = False }))-             "Don't split object files to save space",-      Option "f" ["flags"] (ReqArg (\flags x -> x { rpmConfigurationsFlags = rpmConfigurationsFlags x ++ flagList flags }) "FLAGS")-             "Set given flags in Cabal conditionals",-      Option "" ["release"] (ReqArg (\rel x -> x { rpmRelease = Just rel }) "RELEASE")-             "Override the default package release",-      Option "" ["debdir"] (ReqArg (\path x -> x { debOutputDir = path }) "DEBDIR")-             ("Override the default output directory (" ++ show (debOutputDir emptyFlags) ++ ")"),-      Option "" ["root"] (ReqArg (\ path x -> x { buildRoot = path }) "BUILDROOT")-             "Use the compiler information in the given build environment.",-      Option "v" ["verbose"] (ReqArg (\verb x -> x { rpmVerbosity = readEOrFail flagToVerbosity verb }) "n")-             "Change build verbosity",-      Option "" ["version"] (ReqArg (\vers x -> x { rpmVersion = Just vers }) "VERSION")-             "Override the default package version",-      Option "" ["maintainer"] (ReqArg (\maint x -> x { debMaintainer = Just maint }) "Maintainer Name <email addr>")-             "Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME",-      Option "" ["debianize"] (NoArg (\x -> x {debAction = Debianize}))-             "Generate a new debianization, replacing any existing one.  One of --debianize, --substvar, or --update-debianization is required.",-      Option "" ["build-dep"] (ReqArg (\ name x -> x {buildDeps = name : (buildDeps x)}) "Debian binary package name")-             "Specify a package to add to the build dependency list in debian/control, e.g. '--build-dep libglib2.0-dev'.",-      Option "" ["dev-dep"] (ReqArg (\ name x -> x {extraDevDeps = name : (extraDevDeps x)}) "Debian binary package name")-             "Specify a package to add to the Depends: list of the -dev package, e.g. '--build-dep libssl-dev'.",-      Option "" ["map-dep"] (ReqArg (\ pair x -> x {depMap = case break (== '=') pair of-                                                               (cab, (_ : deb)) -> Map.insertWith (++) cab [BinPkgName (PkgName deb)] (depMap x)-                                                               (_, "") -> error "usage: --dep-map CABALNAME=DEBIANNAME"}) "CABALNAME=DEBIANNAME")-             "Specify a mapping from the name appearing in the Extra-Library field of the cabal file to a debian binary package name, e.g. --dep-map cryptopp=libcrypto-dev",-      -- Option "" ["deb-name"] (ReqArg (\ name x -> x {debName = Just name}) "NAME")-      --        "Specify the base name of the debian package, the part between 'libghc-' and '-dev'.  Normally this is the downcased cabal name.",-      Option "" ["deb-version"] (ReqArg (\ version x -> x {debVersion = Just version}) "VERSION")-             "Specify the version number for the debian package.  This will pin the version and should be considered dangerous.",-      Option "" ["revision"] (ReqArg (\ rev x -> x {revision = rev}) "REVISION")-             "Add this string to the cabal version to get the debian version number.  By default this is '-1~hackage1'.  Debian policy says this must either be empty (--revision '') or begin with a dash.",-      Option "" ["epoch-map"] (ReqArg (\ pair x -> x {epochMap =-                                                          case break (== '=') pair of-                                                            (_, (_ : ['0'])) -> epochMap x-                                                            (cab, (_ : [d])) | isDigit d -> Map.insert (PackageName cab) (ord d - ord '0') (epochMap x)-                                                            _ -> error "usage: --epoch-map CABALNAME=DIGIT"}) "CABALNAME=DIGIT")-             "Specify a mapping from the cabal package name to a digit to use as the debian package epoch number, e.g. --epoch-map HTTP=1",-      Option "" ["substvar"] (ReqArg (\ name x -> x {debAction = SubstVar (read name)}) "Doc, Prof, or Dev")-             (unlines ["Write out the list of dependencies required for the dev, prof or doc package depending",-                       "on the argument.  This value can be added to the appropriate substvars file."]),-      Option "" ["update-debianization"] (NoArg (\x -> x {debAction = UpdateDebianization}))-             "Update an existing debianization, or generate a new one.",-      Option "" ["exec-map"] (ReqArg (\ s x -> x {execMap = case break (== '=') s of-                                                              (cab, (_ : deb)) -> Map.insert cab (BinPkgName (PkgName deb)) (execMap x)-                                                              _ -> error "usage: --exec-map CABALNAME=DEBNAME"}) "EXECNAME=DEBIANNAME")-             "Specify a mapping from the name appearing in the Build-Tool field of the cabal file to a debian binary package name, e.g. --exec-map trhsx=haskell-hsx-utils",-      Option "" ["omit-lt-deps"] (NoArg (\x -> x { omitLTDeps = True }))-             "Don't generate the << dependency when we see a cabal equals dependency.",-      Option "" ["quilt"] (NoArg (\ x -> x {sourceFormat = "3.0 (quilt)"}))-             "The package has an upstream tarball, write '3.0 (quilt)' into source/format."-    ]---- Lifted from Distribution.Simple.Setup, since it's not exported.-flagList :: String -> [(FlagName, Bool)]-flagList = map tagWithValue . words-  where tagWithValue ('-':name) = (FlagName (map toLower name), False)-        tagWithValue name       = (FlagName (map toLower name), True)--printHelp :: Handle -> IO ()--printHelp h = do-    progName <- getProgName-    let info = "Usage: " ++ progName ++ " [FLAGS]\n"-    hPutStrLn h (usageInfo info options)--parseArgs :: [String] -> IO Flags--parseArgs args = do-     let (os, args', unknown, errs) = getOpt' RequireOrder options args-         opts = foldl (flip ($)) emptyFlags os-     when (rpmHelp opts || debAction opts == Usage) $ do-       printHelp stdout-       exitWith ExitSuccess-     when (not (null errs)) $ do-       hPutStrLn stderr "Errors:"-       mapM_ (hPutStrLn stderr) errs-       exitWith (ExitFailure 1)-     when (not (null unknown)) $ do-       hPutStrLn stderr "Unrecognised options:"-       mapM_ (hPutStrLn stderr) unknown-       exitWith (ExitFailure 1)-     when (not (null args')) $ do-       hPutStrLn stderr "Unrecognised arguments:"-       mapM_ (hPutStrLn stderr) args'-       exitWith (ExitFailure 1)-     return opts
Setup.hs view
@@ -1,6 +1,22 @@ #!/usr/bin/runhaskell  import Distribution.Simple+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) import Distribution.Simple.Program+import System.Cmd+import System.Exit -main = defaultMainWithHooks simpleUserHooks+main = defaultMainWithHooks simpleUserHooks {+         postBuild =+             \ _ _ _ lbi ->+                 case buildDir lbi of+                   "dist-ghc/build" -> return ()+                   _ -> runTestScript lbi+       , runTests = \ _ _ _ lbi -> runTestScript lbi+       }++runTestScript lbi =+    system (buildDir lbi ++ "/cabal-debian-tests/cabal-debian-tests") >>= \ code ->+    if code == ExitSuccess then return () else error "unit test failure"++
cabal-debian.cabal view
@@ -1,5 +1,5 @@ Name:           cabal-debian-Version:        1.25+Version:        3.0.3 License:        BSD3 License-File:   debian/copyright Author:         David Fox <dsf@seereason.com>@@ -8,42 +8,85 @@ Homepage:       http://src.seereason.com/cabal-debian Build-Type:     Simple Synopsis:       Create a debianization for a cabal package-Cabal-Version: >= 1.6-Description:-  A program which creates a debian subdirectory containing the required-  files to build a deb.-Data-Files:-  debian/cabal-debian.1,-  debian/cabal-debian.manpages,+Cabal-Version: >= 1.8+Extra-Source-Files:   debian/changelog,-  debian/compat,-  debian/control,-  debian/copyright,-  debian/rules+  debian/Debianize.hs+Description:+ Tool for creating debianizations of Haskell packages based on the .cabal+ file.  If apt-file is installed it will use it to discover what is the+ debian package name of a C library.  Source-Repository head   type: darcs-  location: http://src.seereason.com/cabal-debian+  location: http://src.seereason.com/debian-tools -Flag cabal19- Description: True if Cabal >= 1.9 is available+Library+ Hs-Source-Dirs: src+ GHC-Options: -threaded -Wall -O2+ Build-Depends:+   ansi-wl-pprint,+   applicative-extras,+   base < 5,+   bytestring,+   Cabal >= 1.9,+   containers,+   data-lens,+   debian >= 3.70,+   Diff,+   directory,+   filepath,+   hsemail,+   HUnit,+   mtl,+   network,+   parsec >= 3,+   process,+   pureMD5,+   regex-tdfa,+   syb,+   text,+   unix,+   Unixutils >= 1.50,+   utf8-string+ Exposed-Modules:+   Data.Algorithm.Diff.Context+   Data.Algorithm.Diff.Pretty+   Debian.Debianize+   Debian.Debianize.Atoms+   Debian.Debianize.Bundled+   Debian.Debianize.ControlFile+   Debian.Debianize.Debianize+   Debian.Debianize.Dependencies+   Debian.Debianize.Files+   Debian.Debianize.Finalize+   Debian.Debianize.Generic+   Debian.Debianize.Goodies+   Debian.Debianize.Interspersed+   Debian.Debianize.Input+   Debian.Debianize.Options+   Debian.Debianize.SubstVars+   Debian.Debianize.Tests+   Debian.Debianize.Types+   Debian.Debianize.Utility+   Debian.Orphans+   Debian.Policy+   Distribution.Version.Invert+   Triplets  Executable cabal-debian- Main-is: CabalDebian.hs- ghc-options: -threaded -W- Build-Depends: base < 5, bytestring, Cabal >= 1.6.0.1, containers, debian >= 3.63, directory, filepath, mtl, parsec >= 3, pretty, process, regex-tdfa, unix, Unixutils >= 1.50, utf8-string- Extensions:           ExistentialQuantification CPP- if flag(cabal19)-   build-depends: Cabal >= 1.9-   cpp-options: -DCABAL19- else-   build-depends: Cabal >= 1.8-   cpp-options: -DCABAL18- Other-Modules:-   Distribution.Package.Debian,-   Distribution.Package.Debian.Bundled,-   Distribution.Package.Debian.Dependencies,-   Distribution.Package.Debian.Interspersed,-   Distribution.Package.Debian.Main,-   Distribution.Package.Debian.Relations,-   Distribution.Package.Debian.Setup+ Main-is: src/CabalDebian.hs+ ghc-options: -threaded -Wall -O2+ Build-Depends:+   base,+   cabal-debian,+   containers++Executable cabal-debian-tests+ Main-Is: src/Tests.hs+ GHC-Options: -Wall -O2 -threaded -rtsopts+ Build-Depends:+   base,+   cabal-debian,+   Diff,+   HUnit
+ debian/Debianize.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+import Debian.Debianize+import Data.Lens.Lazy+import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))+import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT))+import Debian.Version (parseDebianVersion)+import Data.Map as Map (insertWith)+import Data.Maybe (fromMaybe)+import Data.Set as Set (insert, union, singleton)+import Data.Text as Text (intercalate)++main :: IO ()+main =+    do 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) $+                setL utilsPackageName (Just (BinPkgName "cabal-debian")) $+                modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") 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"+                                         , " Tool for creating debianizations of Haskell packages based on the .cabal"+                                         , " file.  If apt-file is installed it will use it to discover what is the"+                                         , " debian package name of a C library."+                                         , " ."+                                         , "  Author: David Fox <dsf@seereason.com>"+                                         , "  Upstream-Maintainer: David Fox <dsf@seereason.com>" ])) $+                defaultAtoms)+       inputDebianization "." defaultAtoms >>= \ old -> 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++-- | This copies the first log entry of deb1 into deb2.  Because the+-- debianization process updates that log entry, we need to undo that+-- update in order to get a clean comparison.+copyFirstLogEntry :: Atoms -> Atoms -> Atoms+copyFirstLogEntry deb1 deb2 =+    modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2+    where+      ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1)+      ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2)
− debian/cabal-debian.1 
@@ -1,120 +0,0 @@-.\"Original page generated by txt2man and then hacked extensively.-.TH CABAL-DEBIAN 1  "May 10, 2010"--.SH NAME-cabal-debian \- create Debian package meta data from a Haskell cabal file.--.SH SYNOPSIS-.B cabal-debian-.RI [flags]--.SH DESCRIPTION-cabal-debian will generated the Debian meta data for a Debian package from the-cabal file of a Haskell package. The program expects to find the package's-<pkgname>.cabal file in the directory from which it was run.--.TP-.B-\fB--prefix=PATH\fP-Pass this prefix if we need to configure the package--.TP-.B-\fB--ghc\fP-Compile with GHC.--.TP-.B-\fB--hugs\fP-Compile with HUGS.--.TP-.B-\fB--jhc\fP-Compile with JHC.--.TP-.B-\fB--nhc\fP-Compile with NHC.--.TP-.B-\fB-h, -?, \-\-help\fP-Show this help text.--.TP-.B-\fB--name\fP=NAME-Override the default package name.-.TP-.B-\fB--disable-haddock\fP-Don't generate API docs.-.TP-.B-\fB--disable-library-profiling\fP-Don't generate profiling libraries.-.TP-.B-\fB--disable-optimization\fP-Don't generate optimised code.--.TP-.B-\fB--disable-split-objs\fP-Don't split object files to save space.--.TP-.B-\fB-f\fP FLAGS, \fB--flags\fP=FLAGS-Set given flags in Cabal conditionals.--.TP-.B-\fB--release\fP=RELEASE-Override the default package release.--.TP-.B-\fB--debdir\fP=DEBDIR-Override the default output directory ("./debian").--.TP-.B-\fB-v n,q \fB--verbose=n\fP-Change build verbosity.--.TP-.B-\fB--version\fP=VERSION-Override the default package version.--.TP-.B-\fB--maintainer\fP=Maintainer Name <email addr>-Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME.--.TP-.B-\fB--debianize\fP-Generate a new debianization, replacing any existing one.  One of-\fB--debianize\fP, \fB--substvar\fP, or \fB--update-debianization\fP is-required.--.TP-.B-\fB--substvar\fP=Doc, Prof, or Dev-Write out the list of dependencies required for the dev, prof or doc package-depending on the argument. This value can be added to the appropriate substvars-file.--.TP-.B-\fB--update-debianization\fP-Update an existing debianization.--.SH AUTHOR-This manual page was originally written by Erik de Castro Lopo -<erikd@mega-nerd.com> for the Debian GNU/Linux system (but may be used by -others).
− debian/cabal-debian.manpages 
@@ -1,1 +0,0 @@-debian/*.1
debian/changelog view
@@ -1,3 +1,281 @@+haskell-cabal-debian (3.0.3) unstable; urgency=low++  * Due to a typo, the noDocumentationLibrary lens was turning off+    profiling rather than documentation.++ -- David Fox <dsf@seereason.com>  Fri, 08 Feb 2013 17:14:09 -0800++haskell-cabal-debian (3.0.2) unstable; urgency=low++  * Fix argument and exception handling in cabal-debian+  * Make Standards-Version field non-mandatory+  * Make sure every binary deb paragraph has a non-empty description++ -- David Fox <dsf@seereason.com>  Thu, 07 Feb 2013 10:03:25 -0800++haskell-cabal-debian (3.0.1) unstable; urgency=low++  * Don't build Debian version numbers with revision (Just "").+  * Output the descriptions of the binary packages.++ -- David Fox <dsf@seereason.com>  Tue, 05 Feb 2013 14:48:33 -0800++haskell-cabal-debian (3.0) unstable; urgency=low++  * Moved the Distribution.Debian modules to Debian.Cabal and+    Debian.Debianize.+  * Refactored the debianize function for easier testing+  * Added test cases.+  * Add a Debianization type that intends to fully describe a debian+    package, with functions to read, build, modify, and write a+    Debianization.++ -- David Fox <dsf@seereason.com>  Wed, 26 Dec 2012 05:45:35 -0800++haskell-cabal-debian (2.6.3) unstable; urgency=low++  * Fix pretty printing of Relations (i.e. dependency lists.)  There+    is an instance for printing lists in ansi-wl-pprint which prevents+    us from writing customized Pretty instances for type aliases like+    Relations, AndRelation, and OrRelation.++ -- David Fox <dsf@seereason.com>  Fri, 04 Jan 2013 09:30:48 -0800++haskell-cabal-debian (2.6.2) unstable; urgency=low++  * Fix a bug constructing the destination pathnames that was dropping+    files that were supposed to be installed into packages.++ -- David Fox <dsf@seereason.com>  Thu, 20 Dec 2012 06:49:25 -0800++haskell-cabal-debian (2.6.1) unstable; urgency=low++  * Remove the modifyAtoms field from the Flags record, we want to+    be able to create instances like Read and Show for this type.+    The modifyAtoms function is now passed separately to debianize.+  * The flags field of Server was renamed serverFlags because the+    newly exported Config record has a flags field.++ -- David Fox <dsf@seereason.com>  Wed, 19 Dec 2012 09:45:22 -0800++haskell-cabal-debian (2.5.10) unstable; urgency=low++  * Filter cabal self dependencies out before generating+    Build-Depends-Indep, just as we added code to filter them out+    of Build-Depends in version 2.5.7.++ -- David Fox <dsf@seereason.com>  Tue, 18 Dec 2012 13:23:39 -0800++haskell-cabal-debian (2.5.9) unstable; urgency=low++  * Always add +RTS -IO -RTS to server flags.++ -- David Fox <dsf@seereason.com>  Sun, 16 Dec 2012 10:40:52 -0800++haskell-cabal-debian (2.5.8) unstable; urgency=low++  * Add a builtin list for ghc-7.6.1.++ -- David Fox <dsf@seereason.com>  Sat, 15 Dec 2012 07:04:49 -0800++haskell-cabal-debian (2.5.7) unstable; urgency=low++  * Filter out cabal self-dependencies before building the debian+    dependencies.  In cabal a self dependency means you need the library+    to build an executable, while in debian it means you need an older+    version installed to build the current version.++ -- David Fox <dsf@seereason.com>  Thu, 29 Nov 2012 08:42:30 -0800++haskell-cabal-debian (2.5.6) unstable; urgency=low++  * Don't add --base-uri and --http-port arguments automatically, they can be+    computed by calling the oldClckwrksFlags function and adding the value to+    the flags field.  Clckwrks-0.3 no longer needs the --base-uri argument.++ -- David Fox <dsf@seereason.com>  Tue, 27 Nov 2012 13:34:31 -0800++haskell-cabal-debian (2.5.5) unstable; urgency=low++  * Have the debianize function return False if there is no debian/Debianize.hs file,+    but throw an exception if running it failed, so we notice bad debianization code.++ -- David Fox <dsf@seereason.com>  Tue, 27 Nov 2012 07:34:51 -0800++haskell-cabal-debian (2.5.4) unstable; urgency=low++  * Insert "SetEnv proxy-sendcl 1" line into Apache config.++ -- David Fox <dsf@seereason.com>  Tue, 20 Nov 2012 13:43:54 -0800++haskell-cabal-debian (2.5.3) unstable; urgency=low++  * Remove extra copy of binary from the executable debs+  * Add a sourcePackageName field to Flags, and a --source-package-name+    command line option.++ -- David Fox <dsf@seereason.com>  Sat, 17 Nov 2012 00:16:21 -0800++haskell-cabal-debian (2.5.2) unstable; urgency=low++  * Fix the path to where the DHInstallTo and DHInstallCabalExecTo+    DebAtoms put their files.++ -- David Fox <dsf@seereason.com>  Fri, 16 Nov 2012 18:11:45 -0800++haskell-cabal-debian (2.5.1) unstable; urgency=low++  * Add a destName field to Executable so we can give installed+    executables a different name than they had in the build.++ -- David Fox <dsf@seereason.com>  Fri, 16 Nov 2012 15:37:16 -0800++haskell-cabal-debian (2.5) unstable; urgency=low++  * Add a debName field to the Executable record, before the deb+    package name had to equal the executable name.++ -- David Fox <dsf@seereason.com>  Fri, 16 Nov 2012 12:32:39 -0800++haskell-cabal-debian (2.4.2) unstable; urgency=low++  * Move location of cabal install files from dist/build/install to+    debian/cabalInstall, the dist directory was getting wiped at bad+    moments.+  * Split the autobuilder function autobuilderDebianize into two+    new functions in cabal-debian: runDebianize and callDebianize.+  * Custom debianization code now goes in debian/Debianize.hs rather than+    in setup, so we can distinguish it failing from it not existing more+    easily.++ -- David Fox <dsf@seereason.com>  Thu, 15 Nov 2012 11:00:08 -0800++haskell-cabal-debian (2.4.1) unstable; urgency=low++  * We need to verify that debian/compat was created after running the+    debianize function, because ghc still exits with ExitSuccess++ -- David Fox <dsf@seereason.com>  Thu, 15 Nov 2012 06:34:02 -0800++haskell-cabal-debian (2.4.0) unstable; urgency=low++  * You can run a function in Setup.hs other than main using ghc -e, so we+    will use this trick to run the debianize function directly rather than+    running main.+  * Eliminate the autobuilderDebianize function.++ -- David Fox <dsf@seereason.com>  Thu, 15 Nov 2012 04:05:49 -0800++haskell-cabal-debian (2.3.4) unstable; urgency=low++  * Fix the builddir used when running the cabal-debian standalone+    executable - it was dist-cabal/build, so the resulting debianization+    had files in places where cabal didn't expect them.++ -- David Fox <dsf@seereason.com>  Tue, 13 Nov 2012 06:20:51 -0800++haskell-cabal-debian (2.3.3) unstable; urgency=low++  * Eliminate class MonadBuild and the BuildT monad.++ -- David Fox <dsf@seereason.com>  Sun, 11 Nov 2012 17:46:31 -0800++haskell-cabal-debian (2.3.2) unstable; urgency=low++  * Fix exception that was keeping changelogs from being preserved.++ -- David Fox <dsf@seereason.com>  Sat, 10 Nov 2012 10:07:50 -0800++haskell-cabal-debian (2.3.1) unstable; urgency=low++  * Fix the extension of the debhelper links files+  * Add a general mechanism for installing a file into a deb when+    we have the file's text in a String (rather than in a file.)++ -- David Fox <dsf@seereason.com>  Sat, 10 Nov 2012 07:35:09 -0800++haskell-cabal-debian (2.3) unstable; urgency=low++  * Add MonadBuild.++ -- David Fox <dsf@seereason.com>  Fri, 09 Nov 2012 12:21:14 -0800++haskell-cabal-debian (2.2.1) unstable; urgency=low++  * Add a modifyAtoms function to Flags that is applied to final list of+    DebAtom before writing the debianization.+  * Add DHApacheSite and DHInstallCabalExec atoms so atoms don't depend on+    the build directory+  * Add #DEBHELPER# and exit 0 to default web server postinst.++ -- David Fox <dsf@seereason.com>  Fri, 09 Nov 2012 10:25:32 -0800++haskell-cabal-debian (2.2.0) unstable; urgency=low++  * Append a trailing slash to the --base-uri argument passed to the+    server.  This is required by Web.Routes.Site.runSite.++ -- David Fox <dsf@seereason.com>  Thu, 08 Nov 2012 04:40:08 -0800++haskell-cabal-debian (2.1.4) unstable; urgency=low++  * Merge the Executable and Script constructors of the Executable type+  * Add a destDir field to Executable to specify the destination.++ -- David Fox <dsf@seereason.com>  Tue, 06 Nov 2012 13:24:25 -0800++haskell-cabal-debian (2.1.3) unstable; urgency=low++  * Don't append a slash to the base-uri.+  * Construct the name of the data directory in /usr/share from the cabal+    package name rather than the debian source package name.+  * Add a --self-depend flag to include a build dependency on this library+    in all generated debianizations.++ -- David Fox <dsf@seereason.com>  Tue, 06 Nov 2012 07:07:57 -0800++haskell-cabal-debian (2.1.2) unstable; urgency=low++  * Output the server support files.++ -- David Fox <dsf@seereason.com>  Tue, 06 Nov 2012 06:37:18 -0800++haskell-cabal-debian (2.1.1) unstable; urgency=low++  * Restore code that checks for version number match when validating+    a debianization.  The autobuilder can now pass the version number+    to cabal-debian, so it should match.++ -- David Fox <dsf@seereason.com>  Mon, 05 Nov 2012 17:42:32 -0800++haskell-cabal-debian (2.1.0) unstable; urgency=low++  * Enable processing of Script, Server and WebSite executables.++ -- David Fox <dsf@seereason.com>  Mon, 05 Nov 2012 12:45:42 -0800++haskell-cabal-debian (2.0.9) unstable; urgency=low++  * Add a Library section, export all the modules.++ -- David Fox <dsf@seereason.com>  Mon, 05 Nov 2012 06:41:25 -0800++haskell-cabal-debian (2.0.8) unstable; urgency=low++  * Bypass abandoned versions.++ -- David Fox <dsf@seereason.com>  Sat, 03 Nov 2012 06:13:27 -0700++haskell-cabal-debian (1.26) unstable; urgency=low++  * Don't try to update the existing debianization, except for the+    changelog where we retain entries that look older than the one+    we generate.+  * Use .install files instead of adding rules to debian/rules+  * Add --depends and --conflicts options++ -- David Fox <dsf@seereason.com>  Thu, 25 Oct 2012 12:03:49 -0700+ haskell-cabal-debian (1.25) unstable; urgency=low    * If the --disable-haddock flag is given omit the doc package from the
− debian/compat 
@@ -1,1 +0,0 @@-7
− debian/control 
@@ -1,40 +0,0 @@-Source: haskell-cabal-debian-Priority: extra-Section: haskell-Maintainer: David Fox <dsf@seereason.com>-Build-Depends: debhelper (>= 7.0),-               haskell-devscripts (>= 0.8),-               cdbs,-               ghc,-               ghc-prof,-               libghc-unixutils-dev (>= 1.50),-               libghc-unixutils-prof (>= 1.50),-               libghc-debian-dev (>= 3.63),-               libghc-debian-prof (>= 3.63),-               libghc-mtl-dev,-               libghc-mtl-prof,-               libghc-parsec3-dev (>= 3),-               libghc-parsec3-prof (>= 3),-               libghc-regex-tdfa-dev,-               libghc-regex-tdfa-prof,-               libghc-utf8-string-dev,-               libghc-utf8-string-prof-Build-Depends-Indep: ghc-doc,-                     libghc-unixutils-doc (>= 1.50),-                     libghc-debian-doc (>= 3.63),-                     libghc-mtl-doc,-                     libghc-parsec3-doc (>= 3),-                     libghc-regex-tdfa-doc,-                     libghc-utf8-string-doc-Standards-Version: 3.9.1-Homepage: http://src.seereason.com/cabal-debian--Package: cabal-debian-Architecture: any-Section: misc-Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, apt-file-Conflicts: haskell-debian-utils (<< 3.59)-Description: Create a debianization for a cabal package- Tool for creating debianizations of Haskell packages based on the .cabal- file.  If apt-file is installed it will use it to discover what is the- debian package name of a C library.
− debian/rules 
@@ -1,14 +0,0 @@-#!/usr/bin/make -f--DEB_CABAL_PACKAGE = cabal-debian--include /usr/share/cdbs/1/rules/debhelper.mk-include /usr/share/cdbs/1/class/hlibrary.mk--build/cabal-debian:: build-ghc-stamp-binary-fixup/cabal-debian::-	install -m 755 -s -D dist-ghc/build/cabal-debian/cabal-debian debian/cabal-debian/usr/bin/cabal-debian || true--# How to install an extra file into the documentation package-#binary-fixup/libghc-cabal-debian-doc::-#	echo "Some informative text" > debian/libghc-cabal-debian-doc/usr/share/doc/libghc-cabal-debian-doc/AnExtraDocFile
+ src/CabalDebian.hs view
@@ -0,0 +1,11 @@+-- | This is the main function of the cabal-debian executable.  This+-- is generally run by the autobuilder to debianize packages that+-- don't have any custom debianization code in Setup.hs.  This is a+-- less flexible and powerful method than calling the debianize+-- function directly, many sophisticated configuration options cannot+-- be accessed using the command line interface.++import Debian.Debianize.Debianize (cabalDebian)++main :: IO ()+main = cabalDebian
+ src/Data/Algorithm/Diff/Context.hs view
@@ -0,0 +1,54 @@+module Data.Algorithm.Diff.Context+    ( contextDiff+    , groups+    ) where++import Data.Algorithm.Diff (Diff(..), getGroupedDiff)++-- | Do a grouped diff and then turn it into a list of hunks, where+-- each hunk is a grouped diff with at most N elements of common+-- context around each one.+contextDiff :: Eq a => Int -> [a] -> [a] -> [[Diff [a]]]+contextDiff context a b =+    group $ swap $ trimTail $ trimHead $ concatMap split $ getGroupedDiff a b+    where+      -- Split common runs longer than 2N elements, keeping first and+      -- last N lines.+      split (Both xs ys) =+          case length xs of+            n | n > (2 * context) -> [Both (take context xs) (take context ys), Both (drop (n - context) xs) (drop (n - context) ys)]+            _ -> [Both xs ys]+      split x = [x]+      -- If split created a a pair of Both's at the beginning or end+      -- of the diff, remove the outermost.+      trimHead [] = []+      trimHead [Both _ _] = []+      trimHead [Both _ _, Both _ _] = []+      trimHead (Both _ _ : x@(Both _ _) : more) = x : more+      trimHead xs = trimTail xs+      trimTail [x@(Both _ _), Both _ _] = [x]+      trimTail (x : more) = x : trimTail more+      trimTail [] = []+      -- If we see Second before First swap them so that the deletions+      -- appear before the additions.+      swap (x@(Second _) : y@(First _) : xs) = y : x : swap xs+      swap (x : xs) = x : swap xs+      swap [] = []+      -- Split the list wherever we see adjacent Both constructors+      group xs =+          groups (\ x y -> not (isBoth x && isBoth y)) xs+          where+            isBoth (Both _ _) = True+            isBoth _ = False++-- | Group the elements whose adjacent pairs satisfy the predicate.+-- Differs from groupBy because the predicate does not have to define+-- a total ordering.+groups :: Eq a => (a -> a -> Bool) -> [a] -> [[a]]+groups f xs =+    filter (/= []) $ reverse (groups' [[]] xs)+    where+      groups' (r : rs) (x : y : xs') | f x y = groups' ((x : r) : rs) (y : xs')+      groups' (r : rs) (x : y : xs') = groups' ([y] : reverse (x : r) : rs) xs'+      groups' (r : rs) [y] = reverse (y : r) : rs+      groups' rs [] = rs
+ src/Data/Algorithm/Diff/Pretty.hs view
@@ -0,0 +1,17 @@+module Data.Algorithm.Diff.Pretty+    ( prettyDiff+    ) where++import Data.Algorithm.Diff (Diff(..))+import Data.Monoid (mconcat, (<>))+import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), Doc, text, empty)++prettyDiff :: (Pretty a, Pretty b, Pretty c) => a -> b -> [[Diff [c]]] -> Doc+prettyDiff _ _ [] = empty+prettyDiff old new hunks =+    text "--- " <> pretty old <> text "\n+++ " <> pretty new <> text "\n" <> mconcat (map (\ hunk -> text "@@\n" <> p hunk) hunks)+    where+      p (Both ts _ : more) = mconcat (map (\ l -> text " " <> pretty l <> text "\n") ts) <> p more+      p (First ts : more)  = mconcat (map (\ l -> text "-" <> pretty l <> text "\n") ts) <> p more+      p (Second ts : more) = mconcat (map (\ l -> text "+" <> pretty l <> text "\n") ts) <> p more+      p [] = empty
+ src/Debian/Debianize.hs view
@@ -0,0 +1,73 @@+-- | QUICK START: You can either run the cabal-debian executable, or+-- for more power and flexibility you can construct a+-- 'Debian.Debianize.Atoms' value and pass it to the+-- 'Debian.Debianize.debianize' function.  The+-- 'Debian.Debianize.callDebianize' function retrieves extra arguments+-- from the @CABALDEBIAN@ environment variable and calls+-- 'Debian.Debianize.debianize' with the build directory set as it+-- would be when the packages is built by @dpkg-buildpackage@.+-- +-- To see what your debianization would produce, or how it differs+-- from the debianization already present:+-- +-- > % cabal-debian --debianize -n+-- +-- This is equivalent to the library call+-- +-- > % ghc -e 'Debian.Debianize.callDebianize ["-n"]'+-- +-- To actually create the debianization and then build the debs,+-- +-- > % ghc -e 'Debian.Debianize.callDebianize []'+-- > % sudo dpkg-buildpackage+-- +-- At this point you may need to modify Cabal.defaultFlags to achieve+-- specific packaging goals.  Create a module for this in debian/Debianize.hs:+-- +-- > import Distribution.Debian (Flags(..), defaultFlags)+-- > main = debianize (defaultFlags { extraDevDeps = "haskell-hsx-utils" : extraDevDeps defaultFlags})+-- +-- Then to test it,+-- +-- > % CABALDEBIAN='["-n"]' runhaskell debian/Debianize.hs+-- +-- and to run it+-- +-- > % runhaskell debian/Debianize.hs+module Debian.Debianize+    ( module Debian.Debianize.Atoms+    , module Debian.Debianize.Bundled+    , module Debian.Debianize.ControlFile+    , module Debian.Debianize.Debianize+    , 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+    , module Debian.Debianize.Options+    , module Debian.Debianize.SubstVars+    , module Debian.Debianize.Tests+    , module Debian.Debianize.Types+    , module Debian.Debianize.Utility+    , module Debian.Policy+    ) where++import Debian.Debianize.Atoms+import Debian.Debianize.Bundled+import Debian.Debianize.Debianize+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+import Debian.Debianize.Options+import Debian.Debianize.SubstVars+import Debian.Debianize.Tests+import Debian.Debianize.Types+import Debian.Debianize.ControlFile hiding (depends, conflicts, maintainer, description, section)+import Debian.Debianize.Utility+import Debian.Policy
+ src/Debian/Debianize/Atoms.hs view
@@ -0,0 +1,1207 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections #-}+module Debian.Debianize.Atoms+    ( Atoms+    -- * Modes of operation+    , verbosity+    , dryRun+    , validate+    , debAction+    , flags+    , warning+    -- * Cabal info+    , compilerVersion+    , packageDescription+    , buildDir+    , dataDir+    , compiler+    , extraLibMap+    , execMap+    , cabalFlagAssignments+    -- * Global debian info+    , versionSplits+    , epochMap+    -- * High level information about the debianization+    , description+    , executable+    , serverInfo+    , website+    , backups+    , apacheSite+    , missingDependencies+    , utilsPackageName+    , sourcePackageName+    , revision+    , debVersion+    , maintainer+    , packageInfo+    , omitLTDeps+    , noProfilingLibrary+    , noDocumentationLibrary+    , copyright+    , sourceArchitecture+    , binaryArchitectures+    , sourcePriority+    , binaryPriorities+    , sourceSection+    , binarySections+    , buildDeps+    , buildDepsIndep+    , depends+    , conflicts+    , extraDevDeps+    -- * Debianization files and file fragments+    , rulesHead+    , rulesFragments+    , postInst+    , postRm+    , preInst+    , preRm+    , compat+    , sourceFormat+    , watch+    , changelog+    , comments+    , control+    , standards+    , logrotateStanza+    , link+    , install+    , installTo+    , installData+    , file+    , installCabalExec+    , installCabalExecTo+    , installDir+    , installInit+    , intermediateFiles+    ) where++import Data.Generics (Data, Typeable)+import Data.Lens.Lazy (Lens, lens, getL, modL)+import Data.Map as Map (Map, fold, foldWithKey, insertWith, empty, insert)+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Set as Set (Set, maxView, empty, union, singleton, fold, insert)+import Data.Text (Text)+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.Orphans ()+import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion)+import Debian.Relation (SrcPkgName, BinPkgName, Relation(..))+import Debian.Version (DebianVersion)+import Distribution.License (License)+import Distribution.Package (PackageName(PackageName), PackageIdentifier(..))+import Distribution.PackageDescription as Cabal (PackageDescription(package), FlagName, PackageDescription)+import Distribution.Simple.Compiler (Compiler)+import Prelude hiding (init, unlines, log)+import System.FilePath ((</>))+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)++-- All the internals of this module is a steaming pile of poo, except+-- for the stuff that is exported.++data DebAtomKey+    = Source+    | Binary BinPkgName+    deriving (Eq, Ord, Data, Typeable, Show)++-- | The smallest pieces of debhelper information.  Some of these are+-- converted directly into files in the debian directory, others+-- become fragments of those files, and others are first converted+-- into different DebAtom values as new information becomes available.+data DebAtom+    = NoDocumentationLibrary+    -- ^ Do not produce a libghc-foo-doc package.+    | NoProfilingLibrary+    -- ^ Do not produce a libghc-foo-prof package.+    | CompilerVersion Version+      -- ^ Specify the version number of the GHC compiler in the build+      -- environment.  The default is to assume that version is the same+      -- as the one in the environment where cabal-debian is running.+      -- This is used to look up hard coded lists of packages bundled+      -- with the compiler and their version numbers.  (This could+      -- certainly be done in a more beautiful way.)+    | DHPackageDescription PackageDescription+    -- ^ The cabal package description record+    | DHCompiler Compiler+    -- ^ The Compiler value returned with the Cabal+    -- PackageDescription, then used to determine what libraries+    -- (i.e. dependencies) are provided by the compiler.+    | BuildDir FilePath+    -- ^ The build directory used by cabal, typically dist/build when+    -- building manually or dist-ghc/build when building using GHC and+    -- haskell-devscripts.  This value is used to locate files+    -- produced by cabal so we can move them into the deb.  Note that+    -- the --builddir option of runhaskell Setup appends the "/build"+    -- to the value it receives, so, yes, try not to get confused.+    | DataDir FilePath+    -- ^ the pathname of the package's data directory, generally the+    -- value of the dataDirectory field in the PackageDescription.+    | DebSourceFormat SourceFormat                -- ^ Write debian/source/format+    | DebWatch Text                               -- ^ Write debian/watch+    | DHIntermediate FilePath Text                -- ^ Put this text into a file with the given name in the debianization.+    | DebRulesHead Text				  -- ^ The header of the debian/rules file.  The remainder is assembled+                                                  -- from DebRulesFragment values in the atom list.+    | DebRulesFragment Text                       -- ^ A Fragment of debian/rules+    | Warning Text                                -- ^ A warning to be reported later+    | UtilsPackageName BinPkgName                 -- ^ Name to give the package for left-over data files and executables+    | 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+                                                  -- cabal file, and if it is not there then from the environment.  As a+                                                  -- last resort, there is a hard coded string in here somewhere.+    | DHCabalFlagAssignments (Set (FlagName, Bool)) -- ^ Flags to pass to Cabal function finalizePackageDescription, this+                                                  -- can be used to control the flags in the cabal file.+    | DHFlags Flags                               -- ^ Information regarding mode of operation - verbosity, dry-run, usage, etc+    | DebRevision String			  -- ^ Specify the revision string to use when converting the cabal+                                                  -- version to debian.++    | OmitLTDeps				  -- ^ If present, don't generate the << dependency when we see a cabal+                                                  -- equals dependency.  (The implementation of this was somehow lost.)+    | DebVersion DebianVersion			  -- ^ Specify the exact debian version of the resulting package,+                                                  -- including epoch.  One use case is to work around the the+                                                  -- "buildN" versions that are often uploaded to the debian and+                                                  -- ubuntu repositories.  Say the latest cabal version of+                                                  -- transformers is 0.3.0.0, but the debian repository contains+                                                  -- 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+    | 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,+                                                  -- e.g. @ExtraLibMapping extraLibMap "cryptopp" "libcrypto-dev"@ adds a+                                                  -- build dependency on @libcrypto-dev@ to any package that has @cryptopp@+                                                  -- in its cabal Extra-Library list.+    | ExecMapping String BinPkgName		  -- ^ Map a cabal Build-Tool name to a debian binary package name,+                                                  -- e.g. @ExecMapping "trhsx" "haskell-hsx-utils"@ adds a build+                                                  -- dependency on @haskell-hsx-utils@ to any package that has @trhsx@ in its+                                                  -- cabal build-tool list.+    | EpochMapping PackageName Int		  -- ^ Specify epoch numbers for the debian package generated from a+                                                  -- cabal package.  Example: @EpochMapping (PackageName "HTTP") 1@.+    | DebPackageInfo PackageInfo		  -- ^ Supply some info about a cabal package.+    | DebCompat Int				  -- ^ The debhelper compatibility level, from debian/compat.+    | DebCopyright (Either License Text)	  -- ^ Copyright information, either as a Cabal License value or+                                                  -- the full text.+    | DebControl SourceDebDescription		  -- ^ The parsed contents of the control file++    -- From here down are atoms to be associated with a Debian binary+    -- package.  This could be done with more type safety, separate+    -- maps for the Source atoms and the Binary atoms.+    | DHApacheSite String FilePath Text           -- ^ Have Apache configure a site using PACKAGE, DOMAIN, LOGDIR, and APACHECONFIGFILE+    | DHLogrotateStanza Text		          -- ^ Add a stanza of a logrotate file to the binary package+    | DHLink FilePath FilePath          	  -- ^ Create a symbolic link in the binary package+    | DHPostInst Text			 	  -- ^ Script to run after install, should contain #DEBHELPER# line before exit 0+    | DHPostRm Text                     	  -- ^ Script to run after remove, should contain #DEBHELPER# line before exit 0+    | DHPreInst Text                    	  -- ^ Script to run before install, should contain #DEBHELPER# line before exit 0+    | DHPreRm Text                      	  -- ^ Script to run before remove, should contain #DEBHELPER# line before exit 0+    | DHArch PackageArchitectures       	  -- ^ Set the Architecture field of source or binary+    | DHPriority PackagePriority	       	  -- ^ Set the Priority field of source or binary+    | DHSection Section			       	  -- ^ Set the Section field of source or binary+    | DHDescription Text		       	  -- ^ Set the description of source or binary+    | DHInstall FilePath FilePath       	  -- ^ Install a build file into the binary package+    | DHInstallTo FilePath FilePath     	  -- ^ Install a build file into the binary package at an exact location+    | DHInstallData FilePath FilePath   	  -- ^ DHInstallTo somewhere relative to DataDir (see above)+    | DHFile FilePath Text              	  -- ^ Create a file with the given text at the given path+    | DHInstallCabalExec String FilePath	  -- ^ Install a cabal executable into the binary package+    | DHInstallCabalExecTo String FilePath	  -- ^ Install a cabal executable into the binary package at an exact location+    | DHInstallDir FilePath             	  -- ^ Create a directory in the binary package+    | DHInstallInit Text                	  -- ^ Add an init.d file to the binary package+    | DHExecutable InstallFile                    -- ^ Create a binary package to hold a cabal executable+    | DHServer Server                             -- ^ Like DHExecutable, but configure the executable as a server process+    | DHWebsite Site                              -- ^ Like DHServer, but configure the server as a web server+    | 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+                                                  -- reason to use this is because we don't yet know the name of the dev library package.+    deriving (Eq, Ord, Show, Typeable)++-- | This record supplies information about the task we want done -+-- debianization, validataion, help message, etc.+data Flags = Flags+    {+    -------------------------+    -- Modes of Operation ---+    -------------------------+      verbosity_ :: Int+    -- ^ Run with progress messages at the given level of verboseness.+    , dryRun_ :: Bool+    -- ^ Don't write any files or create any directories, just explain+    -- what would have been done.+    , validate_ :: Bool+    -- ^ Fail if the debianization already present doesn't match the+    -- one we are going to generate closely enough that it is safe to+    -- debianize during the run of dpkg-buildpackage, when Setup+    -- configure is run.  Specifically, the version number in the top+    -- changelog entry must match, and the sets of package names in+    -- the control file must match.+    , debAction_ :: DebAction+    -- ^ What to do - Usage, Debianize or Substvar+    } deriving (Eq, Ord, Show)++-- | Bits and pieces of information about the mapping from cabal package+-- names and versions to debian package names and versions.  In essence,+-- an 'Atoms' value represents a package's debianization.  The lenses in+-- this module are used to get and set the values hidden in this Atoms+-- value.  Many of the values should be left alone to be set when the+-- debianization is finalized.+newtype Atoms = Atoms (Map DebAtomKey (Set DebAtom)) deriving (Eq, Show)++instance Monoid Atoms where+    -- We need mempty to actually be an empty map because we test for+    -- this in the expandAtoms recursion.+    mempty = Atoms mempty -- defaultAtoms+    mappend a b = foldAtoms insertAtom a b++-- Lenses to access values in the Atoms type.  This is an old+-- design which I plan to make private and turn into something+-- nicer, so these will remain ugly and repetitive for now.++-- | Set how much progress messages get generated.+verbosity :: Lens Atoms Int+verbosity = lens (\ a -> verbosity_ (getL flags a)) (\ b a -> modL flags (\ x -> x {verbosity_ = b}) a)++-- | Don't write anything, just output a description of what would have happened+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+validate :: Lens Atoms Bool+validate = lens (\ a -> validate_ (getL flags a)) (\ b a -> modL flags (\ x -> x {validate_ = b}) a)++-- | Debianize, SubstVars, or Usage.  I'm no longer sure what SubstVars does, but someone+-- may still be using it.+debAction :: Lens Atoms DebAction+debAction = lens (\ a -> debAction_ (getL flags a)) (\ b a -> modL flags (\ x -> x {debAction_ = b}) a)++-- | Obsolete record containing verbosity, dryRun, validate, and debAction.+flags :: Lens Atoms Flags+flags = lens g s+    where+      g atoms = fromMaybe defaultFlags $ foldAtoms from Nothing atoms+          where+            from Source (DHFlags x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x')+            from Source (DHFlags x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DHFlags) x)) atoms+          where+            f Source (DHFlags y) = Just y+            f _ _ = Nothing++-- | Unused+warning :: Lens Atoms (Set Text)+warning = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (Warning t) x = Set.insert t x+            from _ _ x = x+      s x atoms = Set.fold (\ text atoms' -> insertAtom Source (Warning text) atoms') (deleteAtoms p atoms) x+          where+            p Source (Warning _) = True+            p _ _ = False+++-- | Set the compiler version, this is used when loading the cabal file to+compilerVersion :: Lens Atoms (Maybe Version)+compilerVersion = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (CompilerVersion x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (CompilerVersion x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . CompilerVersion) x)) atoms+          where+            f Source (CompilerVersion y) = Just y+            f _ _ = Nothing++-- | The information loaded from the cabal file.+packageDescription :: Lens Atoms (Maybe PackageDescription)+packageDescription = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHPackageDescription x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DHPackageDescription x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPackageDescription) x)) atoms+          where+            f Source (DHPackageDescription y) = Just y+            f _ _ = Nothing++-- | The build directory.  This can be set by an argument to the @Setup@ script.+-- When @Setup@ is run manually it is just @dist@, when it is run by+-- @dpkg-buildpackage@ the compiler name is appended, so it is typically+-- @dist-ghc@.  Cabal-debian needs the correct value of buildDir to find+-- the build results.+buildDir :: Lens Atoms (Maybe FilePath)+buildDir = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (BuildDir x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (BuildDir x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . BuildDir) x)) atoms+          where+            f Source (BuildDir y) = Just y+            f _ _ = Nothing++-- | The data directory for the package, generated from the packageDescription+dataDir :: Lens Atoms (Maybe FilePath)+dataDir = lens g s+    where+      g atoms =+          fmap (\ p -> let PackageName pkgname = pkgName. package $ p in+                       "usr/share" </> (pkgname ++ "-" ++ (showVersion . pkgVersion . package $ p))) (getL packageDescription atoms)+      s _ _ = error "setL dataDir"+++-- | The Compiler value returned when the cabal file was loaded.+compiler :: Lens Atoms (Maybe Compiler)+compiler = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHCompiler x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (DHCompiler x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHCompiler) x)) atoms+          where+            f Source (DHCompiler y) = Just y+            f _ _ = Nothing++-- | Map from cabal Extra-Lib names to debian binary package names.+extraLibMap :: Lens Atoms (Map String (Set BinPkgName))+extraLibMap = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from Source (ExtraLibMapping cabal debian) x = Map.insertWith union cabal (singleton debian) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ cabal debian atoms' -> Set.fold (\ debian' atoms'' -> insertAtom Source (ExtraLibMapping cabal debian') atoms'') atoms' debian) (deleteAtoms p atoms) x+          where+            p Source (ExtraLibMapping _ _) = True+            p _ _ = False++-- | Map from cabal Build-Tool names to debian binary package names.+execMap :: Lens Atoms (Map String BinPkgName)+execMap = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from Source (ExecMapping cabal debian) x = Map.insertWith (error "Conflict in execMap") cabal debian x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ cabal debian atoms' -> insertAtom Source (ExecMapping cabal debian) atoms') (deleteAtoms p atoms) x+          where+            p Source (ExecMapping _ _) = True+            p _ _ = False++-- | Cabal flag assignments to use when loading the cabal file.+cabalFlagAssignments :: Lens Atoms (Set (FlagName, Bool))+cabalFlagAssignments = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (DHCabalFlagAssignments pairs) x = union pairs x+            from _ _ x = x+      s x atoms = insertAtom Source (DHCabalFlagAssignments x) (deleteAtoms p atoms)+          where+            p Source (DHCabalFlagAssignments _) = True+            p _ _ = False++-- | 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+    where+      g atoms = foldAtoms from [] atoms+          where+            from Source (DebVersionSplits xs') xs = xs ++ xs'+            from _ _ xs = xs+      s x atoms = insertAtom Source (DebVersionSplits x) (deleteAtoms p atoms)+          where+            p Source (DebVersionSplits _) = True+            p _ _ = False++-- | Map of Debian epoch numbers assigned to cabal packages.+epochMap :: Lens Atoms (Map PackageName Int)+epochMap = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from Source (EpochMapping name epoch) x = Map.insertWith (error "Conflicting Epochs") name epoch x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ name epoch atoms' -> insertAtom Source (EpochMapping name epoch) atoms') (deleteAtoms p atoms) x+          where+            p Source (EpochMapping _ _) = True+            p _ _ = False++-- | Map of binary deb descriptions.+description :: Lens Atoms (Map BinPkgName Text)+description = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHDescription d) x = Map.insertWith (error "description") b d x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHDescription y) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHDescription _) = True+            p _ _ = False++-- | Create a package to hold a cabal executable+executable :: Lens Atoms (Map BinPkgName InstallFile)+executable = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHExecutable f) x = Map.insertWith (error "executable") 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+            p (Binary _) (DHExecutable _) = True+            p _ _ = False++-- | Create a package for an operating service using the given executable+serverInfo :: Lens Atoms (Map BinPkgName Server)+serverInfo = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            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+            p (Binary _) (DHServer _) = True+            p _ _ = False++-- | Create a package for a website using the given executable as the server+website :: Lens Atoms (Map BinPkgName Site)+website = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            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+            p (Binary _) (DHWebsite _) = True+            p _ _ = False++-- | Generate a backups package using the given cabal executable+backups :: Lens Atoms (Map BinPkgName String)+backups = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            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+            p (Binary _) (DHBackups _) = True+            p _ _ = False++-- | Create an apache configuration file with the given+-- (domain, logdir, filetext).  This is called when expanding+-- the result of the website lens above.+apacheSite :: Lens Atoms (Map BinPkgName (String, FilePath, Text))+apacheSite = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHApacheSite dom log text) x = Map.insertWith (error "backups") b (dom, log, text) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b (dom, log, text) atoms' -> insertAtom (Binary b) (DHApacheSite dom log text) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHApacheSite _ _ _) = True+            p _ _ = False++-- * Lower level hints about the debianization+++-- | List if packages that should be omitted from any+-- dependency list - e.g. a profiling package missing due+-- to use of noProfilingPackage lens elsewhere.+missingDependencies :: Lens Atoms (Set BinPkgName)+missingDependencies = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (MissingDependency b) x = Set.insert b x+            from _ _ x = x+      s x atoms = Set.fold (\ b atoms' -> insertAtom Source (MissingDependency b) atoms') (deleteAtoms p atoms) x+          where+            p Source (MissingDependency _) = True+            p _ _ = False++-- | Override the package name used to hold left over data files and executables+utilsPackageName :: Lens Atoms (Maybe BinPkgName)+utilsPackageName = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (UtilsPackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (UtilsPackageName x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . UtilsPackageName) x)) atoms+          where+            f Source (UtilsPackageName y) = Just y+            f _ _ = Nothing++-- | Override the debian source package name constructed from the cabal name+sourcePackageName :: Lens Atoms (Maybe SrcPkgName)+sourcePackageName = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (SourcePackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (SourcePackageName x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . SourcePackageName) x)) atoms+          where+            f Source (SourcePackageName y) = Just y+            f _ _ = Nothing++-- | Revision string used in constructing the debian verison number from the cabal version+revision :: Lens Atoms (Maybe String)+revision = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebRevision x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DebRevision x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRevision) x)) atoms+          where+            f Source (DebRevision y) = Just y+            f _ _ = Nothing++-- | Exact debian version number, overrides the version generated from the cabal version+debVersion :: Lens Atoms (Maybe DebianVersion)+debVersion = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebVersion x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DebVersion x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebVersion) x)) atoms+          where+            f Source (DebVersion y) = Just y+            f _ _ = Nothing++-- | Maintainer field.  Overrides any value found in the cabal file, or+-- in the DEBIANMAINTAINER environment variable.+maintainer :: Lens Atoms (Maybe NameAddr)+maintainer = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHMaintainer x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DHMaintainer x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHMaintainer) x)) atoms+          where+            f Source (DHMaintainer y) = Just y+            f _ _ = Nothing++-- | No longer sure what the purpose of this lens is.+packageInfo :: Lens Atoms (Map PackageName PackageInfo)+packageInfo = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from Source (DebPackageInfo i) x = Map.insert (cabalName i) i x+            from _ _ x = x+      s x atoms =+          Map.fold (\ i atoms' -> insertAtom Source (DebPackageInfo i) atoms') (deleteAtoms p atoms) x+          where+            p Source (DebPackageInfo _) = True+            p _ _ = False++-- | Set this to filter any less-than dependencies out of the generated debian+-- dependencies.  (Not sure if this is implemented.)+omitLTDeps :: Lens Atoms Bool+omitLTDeps = lens g s+    where+      g atoms = foldAtoms from False atoms+          where+            from Source OmitLTDeps _ = True+            from _ _ x = x+      s x atoms = (if x then insertAtom Source OmitLTDeps else id) (deleteAtoms p atoms)+          where+            p Source OmitLTDeps = True+            p _ _ = False++-- | Set this to omit the prof library deb.+noProfilingLibrary :: Lens Atoms Bool+noProfilingLibrary = lens g s+    where+      g atoms = foldAtoms from False atoms+          where+            from Source NoProfilingLibrary _ = True+            from _ _ x = x+      s x atoms = (if x then insertAtom Source NoProfilingLibrary else id) (deleteAtoms p atoms)+          where+            p Source NoProfilingLibrary = True+            p _ _ = False++-- | Set this to omit the doc library deb.+noDocumentationLibrary :: Lens Atoms Bool+noDocumentationLibrary = lens g s+    where+      g atoms = foldAtoms from False atoms+          where+            from Source NoDocumentationLibrary _ = True+            from _ _ x = x+      s x atoms = (if x then insertAtom Source NoDocumentationLibrary else id) (deleteAtoms p atoms)+          where+            p Source NoDocumentationLibrary = True+            p _ _ = False++-- | The copyright information+copyright :: Lens Atoms (Maybe (Either License Text))+copyright = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebCopyright x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DebCopyright x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCopyright) x)) atoms+          where+            f Source (DebCopyright y) = Just y+            f _ _ = Nothing++-- | The source package architecture - @Any@, @All@, or some list of specific architectures.+sourceArchitecture :: Lens Atoms (Maybe PackageArchitectures)+sourceArchitecture = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHArch x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DHArch x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHArch) x)) atoms+          where+            f Source (DHArch y) = Just y+            f _ _ = Nothing++-- | Map of the binary package architectures+binaryArchitectures :: Lens Atoms (Map BinPkgName PackageArchitectures)+binaryArchitectures = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHArch x) m = Map.insert b x m+            from _ _ m = m+      s x atoms = Map.foldWithKey (\ b a atoms' -> insertAtom (Binary b) (DHArch a) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHArch _) = True+            p _ _ = False++-- | The source package priority+sourcePriority :: Lens Atoms (Maybe PackagePriority)+sourcePriority = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHPriority x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DHPriority x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPriority) x)) atoms+          where+            f Source (DHPriority y) = Just y+            f _ _ = Nothing++-- | Map of the binary package priorities+binaryPriorities :: Lens Atoms (Map BinPkgName PackagePriority)+binaryPriorities = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          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+          where+            p (Binary _) (DHPriority _) = True+            p _ _ = False++-- | The source package's section assignment+sourceSection :: Lens Atoms (Maybe Section)+sourceSection = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DHSection x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DHSection x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHSection) x)) atoms+          where+            f Source (DHSection y) = Just y+            f _ _ = Nothing++-- | Map of the binary deb section assignments+binarySections :: Lens Atoms (Map BinPkgName Section)+binarySections = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          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+          where+            p (Binary _) (DHSection _) = True+            p _ _ = False++-- * Debian dependency info++-- | Build dependencies+buildDeps :: Lens Atoms (Set BinPkgName)+buildDeps = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (BuildDep d) x = Set.insert d x+            from _ _ x = x+      s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDep d) atoms') (deleteAtoms p atoms) x+          where+            p Source (BuildDep _) = True+            p _ _ = False++-- | Architecture independent+buildDepsIndep :: Lens Atoms (Set BinPkgName)+buildDepsIndep = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (BuildDepIndep d) x = Set.insert d x+            from _ _ x = x+      s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) x+          where+            p Source (BuildDepIndep _) = True+            p _ _ = False++-- | Map of extra install dependencies for the package's binary debs.+-- This should be [[Relation]] for full generality, or Set (Set Relation)+depends :: Lens Atoms (Map BinPkgName (Set Relation))+depends = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (Depends 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) (Depends rel) atoms'') atoms' rels) (deleteAtoms p atoms) x+          where+            p (Binary _) (Depends _) = True+            p _ _ = False++-- | Map of extra install conflicts for the package's binary debs.+-- We should support all the other dependency fields - provides, replaces, etc.+conflicts :: Lens Atoms (Map BinPkgName (Set Relation))+conflicts = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (Conflicts 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) (Conflicts rel) atoms'') atoms' rels) (deleteAtoms p atoms) x+          where+            p (Binary _) (Conflicts _) = 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 g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (DevDepends b) x = Set.insert b x+            from _ _ x = x+      s x atoms = Set.fold (\ d atoms' -> insertAtom Source (DevDepends d) atoms') (deleteAtoms p atoms) x+          where+            p Source (DevDepends _) = True+            p _ _ = False++-- | The beginning of the rules file+rulesHead :: Lens Atoms (Maybe Text)+rulesHead = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebRulesHead x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')+            from Source (DebRulesHead x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRulesHead) x)) atoms+          where+            f Source (DebRulesHead y) = Just y+            f _ _ = Nothing++-- | Additional fragments of the rules file+rulesFragments :: Lens Atoms (Set Text)+rulesFragments = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (DebRulesFragment t) x = Set.insert t x+            from _ _ x = x+      s x atoms = Set.fold (\ text atoms' -> insertAtom Source (DebRulesFragment text) atoms') (deleteAtoms p atoms) x+          where+            p Source (DebRulesFragment _) = True+            p _ _ = False++-- | Map of @debian/postinst@ scripts+postInst :: Lens Atoms (Map BinPkgName Text)+postInst = lens g s+    where+      g atoms = foldAtoms from mempty atoms+          where+            from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text+            from (Binary b) (DHPostInst t) x = Map.insertWith (error "Conflicting postInsts") b t x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostInst t) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHPostInst _) = True+            p _ _ = False++-- | Map of @debian/postrm@ scripts+postRm :: Lens Atoms (Map BinPkgName Text)+postRm = lens g s+    where+      g atoms = foldAtoms from mempty atoms+          where+            from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text+            from (Binary b) (DHPostRm t) m = Map.insertWith (error "Conflicting postRms") b t m+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostRm t) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHPostRm _) = True+            p _ _ = False++-- | Map of @debian/preinst@ scripts+preInst :: Lens Atoms (Map BinPkgName Text)+preInst = lens g s+    where+      g atoms = foldAtoms from mempty atoms+          where+            from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text+            from (Binary b) (DHPreInst t) m = Map.insertWith (error "Conflicting preInsts") b t m+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreInst t) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHPreInst _) = True+            p _ _ = False++-- | Map of @debian/prerm@ scripts+preRm :: Lens Atoms (Map BinPkgName Text)+preRm = lens g s+    where+      g atoms = foldAtoms from mempty atoms+          where+            from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text+            from (Binary b) (DHPreRm t) m = Map.insertWith (error "Conflicting preRms") b t m+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreRm t) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHPreRm _) = True+            p _ _ = False++-- | The @debian/compat@ file, contains the minimum compatible version of the @debhelper@ package+compat :: Lens Atoms (Maybe Int)+compat = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebCompat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (DebCompat x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCompat) x)) atoms+          where+            f Source (DebCompat y) = Just y+            f _ _ = Nothing++-- | The @debian/source/format@ file.+sourceFormat :: Lens Atoms (Maybe SourceFormat)+sourceFormat = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebSourceFormat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (DebSourceFormat x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebSourceFormat) x)) atoms+          where+            f Source (DebSourceFormat y) = Just y+            f _ _ = Nothing++-- | the @debian/watch@ file+watch :: Lens Atoms (Maybe Text)+watch = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebWatch x') (Just x) | x /= x' = error $ "Conflicting watch values:" ++ show (x, x')+            from Source (DebWatch x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebWatch) x)) atoms+          where+            f Source (DebWatch y) = Just y+            f _ _ = Nothing++-- | the @debian/changelog@ file+changelog :: Lens Atoms (Maybe ChangeLog)+changelog = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebChangeLog x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')+            from Source (DebChangeLog x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebChangeLog) x)) atoms+          where+            f Source (DebChangeLog y) = Just y+            f _ _ = Nothing++-- | Comment entries for the latest changelog entry (DebLogComments [[Text]])+comments :: Lens Atoms (Maybe [[Text]])+comments = lens g s+    where+      g atoms = foldAtoms from Nothing atoms+          where+            from Source (DebLogComments xss') (Just xss) | xss == xss' = error $ "Conflicting log comments: " ++ show (xss, xss')+            from Source (DebLogComments xss) _ = Just xss+            from _ _ x = x+      s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebLogComments) x)) atoms+          where+            f Source (DebLogComments y) = Just y+            f _ _ = Nothing++-- | The @debian/control@ file.+control :: Lens Atoms SourceDebDescription+control = lens g s+    where+      g atoms = fromMaybe newSourceDebDescription $ foldAtoms from Nothing atoms+          where+            from Source (DebControl x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x')+            from Source (DebControl x) _ = Just x+            from _ _ x = x+      s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DebControl) x)) atoms+          where+            f Source (DebControl y) = Just y+            f _ _ = Nothing++-- | 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)+logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text))+logrotateStanza = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHLogrotateStanza r) x = Map.insertWith Set.union b (singleton r) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b ts atoms'-> Set.fold (\ t atoms'' -> insertAtom (Binary b) (DHLogrotateStanza t) atoms'') atoms' ts) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHLogrotateStanza _) = True+            p _ _ = False+link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))+link = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHLink loc txt) x = Map.insertWith Set.union b (singleton (loc, txt)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (loc, txt) atoms'' -> insertAtom (Binary b) (DHLink loc txt) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHLink _ _) = True+            p _ _ = False++-- | Install files into directories+install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))+install = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstall src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstall src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstall _ _) = True+            p _ _ = False++-- | Rename and install files+installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))+installTo = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallTo src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallTo src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallTo _ _) = True+            p _ _ = False++-- | Install files into the package data directory+installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))+installData = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallData src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallData src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallData _ _) = True+            p _ _ = False++-- | Create a file in the deb with the given text+file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text)))+file = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHFile path text) x = Map.insertWith Set.union b (singleton (path, text)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (path, text) atoms'' -> insertAtom (Binary b) (DHFile path text) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHFile _ _) = True+            p _ _ = False++-- | Install a cabal executable+installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath)))+installCabalExec = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallCabalExec name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExec name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallCabalExec _ _) = True+            p _ _ = False++-- | Rename and install a cabal executable+installCabalExecTo :: Lens Atoms (Map BinPkgName (Set (String, FilePath)))+installCabalExecTo = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallCabalExecTo name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExecTo name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallCabalExecTo _ _) = True+            p _ _ = False++-- | Create directories in the package+installDir :: Lens Atoms (Map BinPkgName (Set FilePath))+installDir = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallDir path) x = Map.insertWith Set.union b (singleton path) x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b paths atoms'-> Set.fold (\ path atoms'' -> insertAtom (Binary b) (DHInstallDir path) atoms'') atoms' paths) (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallDir _) = True+            p _ _ = False++-- | Create an /etc/init.d file in the package+installInit :: Lens Atoms (Map BinPkgName Text)+installInit = lens g s+    where+      g atoms = foldAtoms from Map.empty atoms+          where+            from (Binary b) (DHInstallInit text) x = Map.insertWith (error "installInit") b text x+            from _ _ x = x+      s x atoms = Map.foldWithKey (\ b text atoms'-> insertAtom (Binary b) (DHInstallInit text) atoms') (deleteAtoms p atoms) x+          where+            p (Binary _) (DHInstallInit _) = True+            p _ _ = False++-- | Create a file in the debianization.  This is used to implement the file lens above.+intermediateFiles :: Lens Atoms (Set (FilePath, Text))+intermediateFiles = lens g s+    where+      g atoms = foldAtoms from Set.empty atoms+          where+            from Source (DHIntermediate path text) x = Set.insert (path, text) x+            from _ _ x = x+      s x atoms =  Set.fold (\ (path, text) atoms' -> insertAtom Source (DHIntermediate path text) atoms') (deleteAtoms p atoms) x+          where+            p Source (DHIntermediate _ _) = True+            p _ _ = False++defaultFlags :: Flags+defaultFlags =+    Flags {+      verbosity_ = 1+    , debAction_ = Usage+    , dryRun_ = False+    , validate_ = False+    }++insertAtom :: DebAtomKey -> DebAtom -> Atoms -> Atoms+insertAtom mbin atom (Atoms x) = Atoms (insertWith union mbin (singleton atom) x)++insertAtoms :: Set (DebAtomKey, DebAtom) -> Atoms -> Atoms+insertAtoms s atoms =+    case maxView s of+      Nothing -> atoms+      Just ((k, a), s') -> insertAtoms s' (insertAtom k a atoms)++foldAtoms :: (DebAtomKey -> DebAtom -> r -> r) -> r -> Atoms -> r+foldAtoms f r0 (Atoms xs) = Map.foldWithKey (\ k s r -> Set.fold (f k) r s) r0 xs++-- | Split atoms out of an Atoms by predicate.+partitionAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> (Set (DebAtomKey, DebAtom), Atoms)+partitionAtoms f deb =+    foldAtoms g (mempty, Atoms mempty) deb+    where+      g k atom (atoms, deb') =+          case f k atom of+            True -> (Set.insert (k, atom) atoms, deb')+            False -> (atoms, insertAtom k atom deb')++deleteAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> Atoms+deleteAtoms p atoms = snd (partitionAtoms p atoms)++-- | Split atoms out of a Atoms by predicate.+partitionAtoms' :: (Ord a) => (DebAtomKey -> DebAtom -> Maybe a) -> Atoms -> (Set a, Atoms)+partitionAtoms' f deb =+    foldAtoms g (mempty, Atoms mempty) deb+    where+      g k atom (xs, deb') =+          case f k atom of+            Just x -> (Set.insert x xs, deb')+            Nothing -> (xs, insertAtom k atom deb')++-- | Like modifyAtoms, but...+modifyAtoms' :: (Ord a) =>+               (DebAtomKey -> DebAtom -> Maybe a)+            -> (Set a -> Set (DebAtomKey, DebAtom))+            -> Atoms+            -> Atoms+modifyAtoms' f g atoms =+    insertAtoms (g s) atoms'+    where+      (s, atoms') = partitionAtoms' f atoms
+ src/Debian/Debianize/Bundled.hs view
@@ -0,0 +1,388 @@+-- | Determine whether a specific version of a Haskell package is+-- bundled with into this particular version of the given compiler.++{-# LANGUAGE StandaloneDeriving #-}+module Debian.Debianize.Bundled+    ( ghcBuiltIn+    ) where++import qualified Data.Map as Map+import Data.Set (fromList, member)+import Data.Version (Version(..))+import Debian.Relation.ByteString()+import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-})+import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-})++type Bundled = (CompilerFlavor, Version, [PackageIdentifier])++-- |Return a list of built in packages for the compiler in an environment.+-- ghcBuiltIns :: FilePath -> IO [PackageIdentifier]+-- ghcBuiltIns root =+--     fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>=+--     return . map parsePackageIdentifier . words . unpack . fst . collectStdout+--     where+--       parsePackageIdentifier s =+--           let (v', n') = break (== '-') (reverse s)+--               (v, n) = (reverse (tail n'), reverse v') in+--           PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) [])++ghcBuiltIns :: Compiler -> Bundled+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,1,20121207] [], ghc761BuiltIns)+                            , (GHC, Version [7,4,1] [], ghc741BuiltIns)+                            , (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns)+                            , (GHC, Version [7,4,0,20120108] [], ghc740BuiltIns)+                            , (GHC, Version [7,2,2] [], ghc721BuiltIns)+                            , (GHC, Version [7,2,1] [], ghc721BuiltIns)+                            , (GHC, Version [7,0,4] [], ghc701BuiltIns)+                            , (GHC, Version [7,0,3] [], ghc701BuiltIns)+                            , (GHC, Version [7,0,1] [], ghc701BuiltIns)+                            , (GHC, Version [6,8,3] [], ghc683BuiltIns)+                            , (GHC, Version [6,8,2] [], ghc682BuiltIns)+                            , (GHC, Version [6,8,1] [], ghc681BuiltIns)+                            , (GHC, Version [6,6,1] [], ghc661BuiltIns)+                            , (GHC, Version [6,6] [], ghc66BuiltIns) ])) of+      Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion+      Just x -> x+ghcBuiltIns (Compiler {compilerId = _}) = error "ghcBuiltIns: Only GHC is supported"++ghcBuiltIn :: Compiler -> PackageName -> Bool+ghcBuiltIn compiler package =+    Data.Set.member+        package+        (Data.Set.fromList+             (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -}+                  (_, _, xs) = ghcBuiltIns compiler in map pkgName xs))++v :: String -> [Int] -> PackageIdentifier+v n x = PackageIdentifier (PackageName n) (Version x [])++-- Removed: rts, extensible-exceptions+ghc761BuiltIns :: [PackageIdentifier]+ghc761BuiltIns = [+    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,1,20121207],+    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]+    ]++-- | Packages bundled with 7.4.0.20111219-2.+ghc741BuiltIns :: [PackageIdentifier]+ghc741BuiltIns = [+    v "Cabal" [1,14,0],+    v "array" [0,4,0,0],+    v "base" [4,5,0,0],+    v "bin-package-db" [0,0,0,0],+    v "binary" [0,5,1,0],+    v "bytestring" [0,9,2,1],+    v "containers" [0,4,2,1],+    v "deepseq" [1,3,0,0],+    v "directory" [1,1,0,2],+    v "extensible-exceptions" [0,1,1,4],+    v "filepath" [1,3,0,0],+    v "ghc" [7,4,1],+    v "ghc-prim" [0,2,0,0],+    v "haskell2010" [1,1,0,1],+    v "haskell98" [2,0,0,1],+    v "hoopl" [3,8,7,2],+    v "hpc" [0,5,1,1],+    v "integer-gmp" [0,4,0,0],+    v "old-locale" [1,0,0,4],+    v "old-time" [1,1,0,0],+    v "pretty" [1,1,1,0],+    v "process" [1,1,0,1], +    v "rts" [1,0],+    v "template-haskell" [2,7,0,0],+    v "time" [1,4],+    v "unix" [2,5,1,0] ]++-- | Packages bundled with 7.4.0.20111219-2.+ghc740BuiltIns :: [PackageIdentifier]+ghc740BuiltIns = [+    v "Cabal" [1,14,0],+    v "array" [0,4,0,0],+    v "base" [4,5,0,0],+    v "bin-package-db" [0,0,0,0],+    v "binary" [0,5,1,0],+    v "bytestring" [0,9,2,1],+    v "containers" [0,4,2,1],+    v "deepseq" [1,3,0,0],+    v "directory" [1,1,0,2],+    v "extensible-exceptions" [0,1,1,4],+    v "filepath" [1,3,0,0],+    v "ghc" [7,4,0,20111219],+    v "ghc-prim" [0,2,0,0],+    v "haskell2010" [1,1,0,1],+    v "haskell98" [2,0,0,1],+    v "hoopl" [3,8,7,2],+    v "hpc" [0,5,1,1],+    v "integer-gmp" [0,4,0,0],+    v "old-locale" [1,0,0,4],+    v "old-time" [1,1,0,0],+    v "pretty" [1,1,1,0],+    v "process" [1,1,0,1], +    v "rts" [1,0],+    v "template-haskell" [2,7,0,0],+    v "time" [1,4],+    v "unix" [2,5,1,0] ]++ghc721BuiltIns :: [PackageIdentifier]+ghc721BuiltIns = [+    v "Cabal" [1,12,0],+    v "array" [0,3,0,3],+    v "base" [4,4,0,0],+    v "bin-package-db" [0,0,0,0],+    v "binary" [0,5,0,2],+    v "bytestring" [0,9,2,0],+    v "containers" [0,4,1,0],+    v "directory" [1,1,0,1],+    v "extensible-exceptions" [0,1,1,3],+    v "filepath" [1,2,0,1],+    v "ghc" [7,2,1],+    -- ghc-binary renamed to binary+    v "ghc-prim" [0,2,0,0],+    v "haskell2010" [1,1,0,0],+    v "haskell98" [2,0,0,0],+    v "hoopl" [3,8,7,1], -- new+    v "hpc" [0,5,1,0],+    v "integer-gmp" [0,3,0,0],+    v "old-locale" [1,0,0,3],+    v "old-time" [1,0,0,7],+    v "pretty" [1,1,0,0],+    v "process" [1,1,0,0], +    -- random removed+    v "rts" [1,0],+    v "template-haskell" [2,6,0,0],+    v "time" [1,2,0,5],+    v "unix" [2,5,0,0] ]++ghc701BuiltIns :: [PackageIdentifier]+ghc701BuiltIns = [+    v "Cabal" [1,10,0,0],+    v "array" [0,3,0,2],+    v "base" [4,3,0,0],+    v "bin-package-db" [0,0,0,0],+    v "bytestring" [0,9,1,8],+    v "containers" [0,4,0,0],+    v "directory" [1,1,0,0],+    v "extensible-exceptions" [0,1,1,2],+    v "filepath" [1,2,0,0],+    v "ghc" [7,0,1],+    v "ghc-binary" [0,5,0,2],+    v "ghc-prim" [0,2,0,0],+    v "haskell2010" [1,0,0,0],+    v "haskell98" [1,1,0,0],+    v "hpc" [0,5,0,6],+    v "integer-gmp" [0,2,0,2],+    v "old-locale" [1,0,0,2],+    v "old-time" [1,0,0,6],+    v "pretty" [1,0,1,2],+    v "process" [1,0,1,4],+    v "random" [1,0,0,3],+    v "rts" [1,0],+    v "template-haskell" [2,5,0,0],+    v "time" [1,2,0,3],+    v "unix" [2,4,1,0]+  ]++ghc683BuiltIns :: [PackageIdentifier]+ghc683BuiltIns = ghc682BuiltIns++ghc682BuiltIns :: [PackageIdentifier]+ghc682BuiltIns = [+    v "Cabal" [1,2,3,0],+    v "array" [0,1,0,0],+    v "base" [3,0,1,0],+    v "bytestring" [0,9,0,1],+    v "containers" [0,1,0,1],+    v "directory" [1,0,0,0],+    v "filepath" [1,1,0,0],+    v "ghc" [6,8,2,0],+    v "haskell98" [1,0,1,0],+    v "hpc" [0,5,0,0],+    v "old-locale" [1,0,0,0],+    v "old-time" [1,0,0,0],+    v "packedstring" [0,1,0,0],+    v "pretty" [1,0,0,0],+    v "process" [1,0,0,0],+    v "random" [1,0,0,0],+    v "readline" [1,0,1,0],+    v "template-haskell" [2,2,0,0],+    v "unix" [2,3,0,0]+    ]++ghc681BuiltIns :: [PackageIdentifier]+ghc681BuiltIns = [+    v "base" [3,0,0,0],+    v "Cabal" [1,2,2,0],+    v "GLUT" [2,1,1,1],+    v "HGL" [3,2,0,0],+    v "HUnit" [1,2,0,0],+    v "OpenAL" [1,3,1,1],+    v "OpenGL" [2,2,1,1],+    v "QuickCheck" [1,1,0,0],+    v "X11" [1,2,3,1],+    v "array" [0,1,0,0],+    v "bytestring" [0,9,0,1],+    v "cgi" [3001,1,5,1],+    v "containers" [0,1,0,0],+    v "directory" [1,0,0,0],+    v "fgl" [5,4,1,1],+    v "filepatch" [1,1,0,0],+    v "ghc" [6,8,1,0],+    v "haskell-src" [1,0,1,1],+    v "haskell98" [1,0,1,0],+    v "hpc" [0,5,0,0],+    v "html" [1,0,1,1],+    v "mtl" [1,1,0,0],+    v "network" [2,1,0,0],+    v "old-locale" [1,0,0,0],+    v "old-time" [1,0,0,0],+    v "packedstring" [0,1,0,0],+    v "parallel" [1,0,0,0],+    v "parsec" [2,1,0,0],+    v "pretty" [1,0,0,0],+    v "process" [1,0,0,0],+    v "random" [1,0,0,0],+    v "readline" [1,0,1,0],+    v "regex-base" [0,72,0,1],+    v "regex-compat" [0,71,0,1],+    v "regex-posix" [0,72,0,1],+    v "stm" [2,1,1,0],+    v "template-haskell" [2,2,0,0],+    v "time" [1,1,2,0],+    v "unix" [2,2,0,0],+    v "xhtml" [3000,0,2,1]+    ]++ghc661BuiltIns :: [PackageIdentifier]+ghc661BuiltIns = [+    v "base" [2,1,1],+    v "Cabal" [1,1,6,2],+    v "cgi" [3001,1,1],+    v "fgl" [5,4,1],+    v "filepath" [1,0],+    v "ghc" [6,6,1],+    v "GLUT" [2,1,1],+    v "haskell98" [1,0],+    v "haskell-src" [1,0,1],+    v "HGL" [3,1,1],+    v "html" [1,0,1],+    v "HUnit" [1,1,1],+    v "mtl" [1,0,1],+    v "network" [2,0,1],+    v "OpenAL" [1,3,1],+    v "OpenGL" [2,2,1],+    v "parsec" [2,0],+    v "QuickCheck" [1,0,1],+    v "readline" [1,0],+    v "regex-base" [0,72],+    v "regex-compat" [0,71],+    v "regex-posix" [0,71],+    v "rts" [1,0],+    v "stm" [2,0],+    v "template-haskell" [2,1],+    v "time" [1,1,1],+    v "unix" [2,1],+    v "X11" [1,2,1],+    v "xhtml" [3000,0,2]+    ]++ghc66BuiltIns :: [PackageIdentifier]+ghc66BuiltIns = [+    v "base" [2,0],+    v "Cabal" [1,1,6],+    v "cgi" [2006,9,6],+    v "fgl" [5,2],+    v "ghc" [6,6],+    v "GLUT" [2,0],+    v "haskell98" [1,0],+    v "haskell-src" [1,0],+    v "HGL" [3,1],+    v "html" [1,0],+    v "HTTP" [2006,7,7],+    v "HUnit" [1,1],+    v "mtl" [1,0],+    v "network" [2,0],+    v "OpenAL" [1,3],+    v "OpenGL" [2,1],+    v "parsec" [2,0],+    v "QuickCheck" [1,0],+    v "readline" [1,0],+    v "regex-base" [0,71],+    v "regex-compat" [0,71],+    v "regex-posix" [0,71],+    v "rts" [1,0],+    v "stm" [2,0],+    v "template-haskell" [2,0],+    v "time" [1,0],+    v "unix" [1,0],+    v "X11" [1,1],+    v "xhtml" [2006,9,13]+    ]++-- Script to output a list of the libraries in the ghc package+-- provides line.  This could be run inside the build environment+-- instead of having these hard coded lists.+--+-- apt-cache show ghc \+--   | grep ^Provides: \+--   | cut -d\  -f2-+--   | sed 's/, /\n/g' \+--   | grep libghc- \+--   | cut -d- -f2- \+--   | grep dev$ \+--   | sort -u \+--   | sed 's/-dev//;s/$/",/;s/^/"/'+--+-- base :: Set String+-- base+--   = Data.Set.fromList+--     [ "array",+--       "base",+--       "binary",+--       "bin-package-db",+--       "bytestring",+--       "cabal",+--       "containers",+--       "deepseq",+--       "directory",+--       "extensible-exceptions",+--       "filepath",+--       "ghc-prim",+--       "haskell2010",+--       "haskell98",+--       "hoopl",+--       "hpc",+--       "integer-gmp",+--       "old-locale",+--       "old-time",+--       "pretty",+--       "process",+--       "rts",+--       "template-haskell",+--       "time",+--       "unix" ]
+ src/Debian/Debianize/ControlFile.hs view
@@ -0,0 +1,206 @@+-- | Preliminary.+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}+module Debian.Debianize.ControlFile+    ( SourceDebDescription(..)+    , newSourceDebDescription+    , newSourceDebDescription'+    , VersionControlSpec(..)+    , XField(..)+    , XFieldDest(..)+    , BinaryDebDescription(..)+    , newBinaryDebDescription+    , modifyBinaryDeb+    -- , modifyBinaryDescription+    , PackageRelations(..)+    , PackageType(..)+    , packageArch+    ) where++import Data.Generics (Data, Typeable)+import Data.Monoid (mempty)+import Data.Set as Set (Set, empty)+import Data.Text (Text)+import Debian.Orphans ()+import Debian.Policy (StandardsVersion, PackagePriority, PackageArchitectures(..), Section)+import Debian.Relation (Relations, SrcPkgName(..), BinPkgName)+import Prelude hiding (init, log)+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)++-- | This type represents the debian/control file, which is the core+-- of the source package debianization.  It includes the information+-- that goes in the first, or source, section, and then a list of the+-- succeeding binary package sections.+data SourceDebDescription+    = SourceDebDescription+      { source :: Maybe SrcPkgName+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Source>+      , maintainer :: Maybe NameAddr+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Maintainer>+      , changedBy :: Maybe NameAddr+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Changed-By>+      , uploaders :: [NameAddr]+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Uploaders>+      , dmUploadAllowed :: Bool+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-DM-Upload-Allowed>+      , priority :: Maybe PackagePriority+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Priority>+      , section :: Maybe Section+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Section>+      , standardsVersion :: Maybe StandardsVersion+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Standards-Version>+      , homepage :: Maybe Text+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Homepage>+      , vcsFields :: Set VersionControlSpec+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-VCS-fields>+      , xFields :: Set XField+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.7>+      , buildDepends :: Relations+      , buildConflicts :: Relations+      , buildDependsIndep :: Relations+      , buildConflictsIndep :: Relations+      , binaryPackages :: [BinaryDebDescription] -- This should perhaps be a set, or a map+      } deriving (Eq, Ord, Show, Data, Typeable)++newSourceDebDescription :: SourceDebDescription+newSourceDebDescription =+    SourceDebDescription+      { source = Nothing+      , maintainer = Nothing+      , changedBy = Nothing+      , uploaders = []+      , dmUploadAllowed = False+      , priority = Nothing+      , section = Nothing+      , buildDepends = []+      , buildConflicts = []+      , buildDependsIndep  = []+      , buildConflictsIndep  = []+      , standardsVersion = Nothing+      , homepage = Nothing+      , vcsFields = Set.empty+      , xFields = Set.empty+      , binaryPackages = [] }++newSourceDebDescription' :: SrcPkgName -> NameAddr -> SourceDebDescription+newSourceDebDescription' src who =+    newSourceDebDescription+      { source = Just src+      , maintainer = Just who }++data VersionControlSpec+    = VCSBrowser Text+    | VCSArch Text+    | VCSBzr Text+    | VCSCvs Text+    | VCSDarcs Text+    | VCSGit Text+    | VCSHg Text+    | VCSMtn Text+    | VCSSvn Text+    deriving (Eq, Ord, Show, Data, Typeable)++-- | User defined fields.  Parse the line "XBS-Comment: I stand+-- between the candle and the star." to get XField (fromList "BS")+-- "Comment" " I stand between the candle and the star."+data XField+    = XField (Set XFieldDest) Text Text+    deriving (Eq, Ord, Show, Data, Typeable)++data XFieldDest+    = B -- ^ Field will be copied to the binary packgae control files+    | S -- ^ Field will be copied to the source packgae control files+    | C -- ^ Field will be copied to the upload control (.changes) file+    deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | This type represents a section of the control file other than the+-- first, which in turn represent one of the binary packages or debs+-- produced by this debianization.+data BinaryDebDescription+    = BinaryDebDescription+      { package :: BinPkgName+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package>+      , architecture :: PackageArchitectures+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Architecture>+      , binarySection :: Maybe Section+      , binaryPriority :: Maybe PackagePriority+      , essential :: Bool+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Essential>+      , description :: Text+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Description>+      , relations :: PackageRelations+      -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.6.10>+      } deriving (Eq, Ord, Read, Show, Data, Typeable)++newBinaryDebDescription :: BinPkgName -> PackageArchitectures -> BinaryDebDescription+newBinaryDebDescription name arch =+    BinaryDebDescription+      { package = name -- mkPkgName base typ+      , architecture = arch -- packageArch typ+      , binarySection = Nothing+      , binaryPriority = Nothing+      , essential = False+      , description = mempty+      , relations = newPackageRelations }++-- | Modify the description of one of the binary debs without changing+-- the package order.+modifyBinaryDeb :: BinPkgName -> (Maybe BinaryDebDescription -> BinaryDebDescription) -> SourceDebDescription -> SourceDebDescription+modifyBinaryDeb bin f deb =+    deb {binaryPackages = bins'}+    where+      bins' = if any (\ x -> package x == bin) bins+             then map g (binaryPackages deb)+             else binaryPackages deb ++ [f Nothing]+      g x = if package x == bin then f (Just x) else x+      bins = binaryPackages deb++-- ^ Package interrelationship information.+data PackageRelations+    = PackageRelations+      { depends :: Relations+      , recommends :: Relations+      , suggests :: Relations+      , preDepends :: Relations+      , breaks :: Relations+      , conflicts :: Relations+      , provides :: Relations+      , replaces :: Relations+      , builtUsing :: Relations+      } deriving (Eq, Ord, Read, Show, Data, Typeable)++newPackageRelations :: PackageRelations+newPackageRelations =+    PackageRelations+      { depends = []+      , recommends = []+      , suggests = []+      , preDepends = []+      , breaks = []+      , conflicts = []+      , provides = []+      , replaces = []+      , builtUsing = [] }++-- ^ The different types of binary debs we can produce from a haskell package+data PackageType+    = Development   -- ^ The libghc-foo-dev package.+    | Profiling     -- ^ The libghc-foo-prof package.+    | Documentation -- ^ The libghc-foo-doc package.+    | Exec          -- ^ A package related to a particular executable, perhaps+                    -- but not necessarily a server.+    | Utilities     -- ^ A package that holds the package's data files+                    -- and any executables not assigned to other+                    -- packages.+    | Source'       -- ^ The source package (not a binary deb actually.)+    | Cabal         -- ^ This is used to construct the value for+                    -- DEB_CABAL_PACKAGE in the rules file+    deriving (Eq, Show)++packageArch :: PackageType -> PackageArchitectures+packageArch Development = Any+packageArch Profiling = Any+packageArch Documentation = All+packageArch Utilities = All+packageArch Exec = Any+packageArch Cabal = undefined+packageArch Source' = undefined
+ src/Debian/Debianize/Debianize.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}++-- | Generate a package Debianization from Cabal data and command line+-- options.++module Debian.Debianize.Debianize+    ( cabalDebian+    , callDebianize+    , runDebianize+    , debianize+    , debianization+    , writeDebianization+    , describeDebianization+    , compareDebianization+    , validateDebianization+    ) where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Exception (catch)+import Data.Algorithm.Diff.Context (contextDiff)+import Data.Algorithm.Diff.Pretty (prettyDiff)+import Data.Lens.Lazy (getL, setL, modL)+import Data.List as List (unlines, intercalate, nub)+import Data.Map as Map (lookup, toList, elems)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Set as Set (toList)+import Data.Text as Text (Text, unpack, split)+import Data.Version (Version)+import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))+import Debian.Debianize.Atoms (Atoms, packageDescription, compat, watch, control, copyright, changelog, comments,+                               sourcePriority, sourceSection, debAction, validate, dryRun, debVersion, revision,+                               sourcePackageName, epochMap, extraLibMap)+import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), PackageType(..))+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.Options (options, compileArgs)+import Debian.Debianize.SubstVars (substvars)+import Debian.Debianize.Types (DebAction(..))+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.Package (PackageIdentifier(..))+import qualified Distribution.PackageDescription as Cabal+import Prelude hiding (writeFile, unlines)+import System.Console.GetOpt (usageInfo)+import System.Directory (doesFileExist, Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing)+import System.Environment (getArgs, getEnv, getProgName)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath ((</>), takeDirectory)+import System.IO.Error (catchIOError)+import System.Posix.Env (setEnv)+import System.Process (readProcessWithExitCode)+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)+import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))++{-+import Debian.Debianize.ControlFile as Debian (SourceDebDescription(source, binaryPackages), BinaryDebDescription(package))+import Debian.Debianize.Files (toFileMap)+import Debian.Debianize.Goodies (defaultAtoms)+import Debian.Debianize.Input (inputDebianization)+import Debian.Debianize.Utility (withCurrentDirectory)+import System.Directory (Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing)+import Text.PrettyPrint.ANSI.Leijen (pretty)+-}++-- | The main function for the cabal-debian executable.+cabalDebian :: IO ()+cabalDebian =+    compileAllArgs defaultAtoms >>= \ atoms ->+      case getL debAction atoms of+        SubstVar debType -> substvars atoms debType+        Debianize ->  debianize "." atoms+        Usage -> do+          progName <- getProgName+          let info = "Usage: " ++ progName ++ " [FLAGS]\n"+          putStrLn (usageInfo info options)++-- | Compile the given arguments into an Atoms value and run the+-- 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 >>= debianize "." . compileArgs args++-- | Put an argument list into the @CABALDEBIAN@ environment variable+-- and then run the script in debian/Debianize.hs.  If this exists and+-- succeeds the return value is True, it may be assumed that a+-- debianization was created in the debian subdirectory of the current+-- directory.  This is used to create customized debianizations that+-- are to sophisticated for the command line argument interface+-- available to the cabal-debian executable.+runDebianize :: [String] -> IO Bool+runDebianize args =+    doesFileExist "debian/Debianize.hs" >>= \ exists ->+    case exists of+      False -> return False+      True ->+          putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ("debian/Debianize.hs" : args) "" >>= \ result ->+          case result of+            (ExitSuccess, _, _) -> return True+            (code, out, err) ->+              error ("runDebianize failed with " ++ show code ++ ":\n stdout: " ++ show out ++"\n stderr: " ++ show err)++-- | Generate a debianization, and then either validate, describe, or+-- write it out dependeing on the command line arguments.+debianize :: FilePath -> Atoms -> IO ()+debianize top atoms =+    debianization top atoms >>= \ atoms' ->+    if getL validate atoms'+    then inputDebianization top >>= \ old -> either error 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'++-- | 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+       date <- getCurrentLocalRFC822Time+       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'++debianization' :: String              -- ^ current date+               -> Text                -- ^ copyright+               -> NameAddr            -- ^ maintainer+               -> Int		-- ^ Default standards version+               -> Maybe ChangeLog+               -> Atoms      -- ^ Debianization specification+               -> Atoms      -- ^ New debianization+debianization' date copyright' maint level log deb =+    finalizeDebianization $+    modL compat (maybe (Just level) Just) $+    modL changelog (maybe log Just) $+    setL sourcePriority (Just Optional) $+    setL sourceSection (Just (MainSection "haskell")) $+    setL watch (Just (watchAtom (pkgName $ Cabal.package $ pkgDesc)))  $+    setL copyright (Just (Right copyright')) $+    versionInfo maint date $+    addExtraLibDependencies $+    -- Do we want to replace the atoms in the old deb, or add these?+    -- Or should we delete even more information from the original,+    -- keeping only the changelog?  Probably the latter.  So this is+    -- somewhat wrong.+    deb+    where+      pkgDesc = fromMaybe (error "debianization") $ getL packageDescription deb++-- | Set the debianization's version info - everything that goes into+-- the new changelog entry, source package name, exact debian version,+-- log comments, maintainer name, revision date.+versionInfo :: NameAddr -> String -> Atoms -> Atoms+versionInfo debianMaintainer date deb =+    modL changelog (const (Just newLog)) $+    modL control (\ y -> y { source = Just sourceName, Debian.maintainer = Just debianMaintainer }) deb+    where+      newLog =+          case getL changelog deb of+            Nothing -> ChangeLog [newEntry]+            Just (ChangeLog oldEntries) ->+                case dropWhile (\ entry -> logVersion entry > logVersion newEntry) oldEntries of+                  -- If the new package version number matches the old, merge the new and existing log entries+                  entry@(Entry {logVersion = d}) : older | d == logVersion newEntry -> ChangeLog (merge entry newEntry : older)+                  -- Otherwise prepend the new entry+                  entries -> ChangeLog (newEntry : entries)+      newEntry = Entry { logPackage = show (pretty sourceName)+                       , logVersion = convertVersion debinfo (pkgVersion pkgId)+                       , logDists = [parseReleaseName "unstable"]+                       , logUrgency = "low"+                       , logComments = List.unlines $ (map (("  * " <>) . List.intercalate "\n    " . map unpack)) (fromMaybe [["Debianization generated by cabal-debian"]] (getL comments deb))+                       , logWho = show (pretty debianMaintainer)+                       , logDate = date }+      -- Get the source package name, either from the SourcePackageName+      -- atom or construct it from the cabal package name.+      sourceName :: SrcPkgName+      sourceName = maybe (debianName deb Source' pkgId) id (getL sourcePackageName deb)+      merge :: ChangeLogEntry -> ChangeLogEntry -> ChangeLogEntry+      merge old new =+          old { logComments = logComments old ++ logComments new+              , logDate = date }+      debinfo = maybe (Right (epoch, fromMaybe "" (getL revision deb))) Left (getL debVersion deb)+      epoch = Map.lookup (pkgName pkgId) (getL epochMap deb)+      pkgId = Cabal.package pkgDesc+      pkgDesc = fromMaybe (error "versionInfo: no PackageDescription") $ getL packageDescription deb++-- | Combine various bits of information to produce the debian version+-- which will be used for the debian package.  If the override+-- parameter is provided this exact version will be used, but an error+-- will be thrown if that version is unusably old - i.e. older than+-- the cabal version of the package.  Otherwise, the cabal version is+-- combined with the given epoch number and revision string to create+-- a version.+convertVersion :: Either DebianVersion (Maybe Int, String) -> Version -> DebianVersion+convertVersion debinfo cabalVersion =+    case debinfo of+      Left override | override >= parseDebianVersion (show (pretty cabalVersion)) -> override+      Left override -> error ("Version from --deb-version (" ++ show (pretty override) +++                              ") is older than hackage version (" ++ show (pretty cabalVersion) +++                              "), maybe you need to unpin this package?")+      Right (debianEpoch, debianRevision) ->+          buildDebianVersion debianEpoch+                             (show (pretty cabalVersion))+                             (foldEmpty Nothing Just debianRevision)++-- | Convert the extraLibs field of the cabal build info into debian+-- binary package names and make them dependendencies of the debian+-- devel package (if there is one.)+addExtraLibDependencies :: Atoms -> Atoms+addExtraLibDependencies deb =+    modL control (\ y -> y {binaryPackages = map f (binaryPackages (getL control deb))}) deb+    where+      f :: BinaryDebDescription -> BinaryDebDescription+      f bin+          | debianName deb Development (Cabal.package pkgDesc) == Debian.package bin+              = bin { relations = g (relations bin) }+      f bin = bin+      g :: Debian.PackageRelations -> Debian.PackageRelations+      g rels = rels { Debian.depends = Debian.depends rels +++                                map anyrel' (concatMap (\ cab -> maybe [BinPkgName ("lib" ++ cab ++ "-dev")] Set.toList (Map.lookup cab (getL extraLibMap deb)))+                                                       (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc)) }+      pkgDesc = fromMaybe (error "addExtraLibDependencies: no PackageDescription") $ getL packageDescription deb++anyrel' :: BinPkgName -> [Relation]+anyrel' x = [Rel x Nothing Nothing]++compileAllArgs :: Atoms -> IO Atoms+compileAllArgs atoms0 = compileEnvironmentArgs atoms0 >>= compileCommandlineArgs++compileEnvironmentArgs :: Atoms -> IO Atoms+compileEnvironmentArgs atoms0 = (compileArgs <$> (read <$> getEnv "CABALDEBIAN") <*> pure atoms0) `catchIOError` const (return atoms0)++compileCommandlineArgs :: Atoms -> IO Atoms+compileCommandlineArgs atoms0 = compileArgs <$> getArgs <*> pure atoms0++-- | Insert a value for CABALDEBIAN into the environment that the+-- withEnvironment* functions above will find and use.  E.g.+-- putEnvironmentFlags ["--dry-run", "--validate"] (debianize defaultFlags)+putEnvironmentArgs :: [String] -> IO ()+putEnvironmentArgs fs = setEnv "CABALDEBIAN" (show fs) True++-- | Write the files of the debianization @d@ to the directory @top@.+writeDebianization :: FilePath -> Atoms -> IO ()+writeDebianization top d =+    withCurrentDirectory top $+      mapM_ (\ (path, text) ->+                 createDirectoryIfMissing True (takeDirectory path) >>+                 replaceFile path (unpack text))+            (Map.toList (toFileMap d)) >>+      getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True})++describeDebianization :: Atoms -> String+describeDebianization atoms =+    concatMap (\ (path, text) -> path ++ ":\n" ++ indent " > " (unpack text)) (Map.toList (toFileMap atoms))++-- | Compare the existing debianization in @top@ to the generated one+-- @new@, returning a string describing the differences.+compareDebianization :: Atoms -> Atoms -> String+compareDebianization old new =+    concat . Map.elems $ zipMaps doFile (toFileMap old) (toFileMap new)+    where+      doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String+      doFile path (Just _) Nothing = Just (path ++ ": Deleted\n")+      doFile path Nothing (Just n) = Just (path ++ ": Created\n" ++ indent " | " (unpack n))+      doFile path (Just o) (Just n) =+          if o == n+          then Nothing -- Just (path ++ ": Unchanged\n")+          else Just (show (prettyDiff ("old" </> path) ("new" </> path) (contextDiff 2 (split (== '\n') o) (split (== '\n') n))))+      doFile _path Nothing Nothing = error "Internal error in zipMaps"++-- | Don't change anything, just make sure the new debianization+-- matches the existing debianization in several particulars -+-- specifically, version number, and source and binary package names.+validateDebianization :: Atoms -> Atoms -> Either String ()+validateDebianization old new =+    case () of+      _ | oldVersion /= newVersion -> Left ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion))+        | oldSource /= newSource -> Left ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource))+        | oldPackages /= newPackages -> Left ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages))+        | True -> Right ()+    where+      oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog old))))+      newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog new))))+      oldSource = source . getL control $ old+      newSource = source . getL control $ new+      oldPackages = map Debian.package . binaryPackages . getL control $ old+      newPackages = map Debian.package . binaryPackages . getL control $ new+      unChangeLog :: ChangeLog -> [ChangeLogEntry]+      unChangeLog (ChangeLog x) = x
+ src/Debian/Debianize/Dependencies.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}+{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}+module Debian.Debianize.Dependencies+    ( cabalDependencies -- Debian.Cabal.SubstVars+    , selfDependency -- Debian.Debianize.Combinators+    , allBuildDepends+    , debDeps+    , putBuildDeps+    , dependencies+    , debianName+    , debNameFromType+    , getRulesHead+    , filterMissing+    , binaryPackageDeps+    , binaryPackageConflicts+    ) 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.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 Debian.Control+import Debian.Debianize.Atoms (Atoms, packageDescription, rulesHead, compiler, noProfilingLibrary, noDocumentationLibrary,+                               missingDependencies, versionSplits, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap,+                               packageInfo, depends, conflicts, 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.Orphans ()+import qualified Debian.Relation as D+import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(pkgNameFromString))+import Debian.Version (parseDebianVersion)+import Distribution.Package (PackageName(PackageName), PackageIdentifier(..), Dependency(..))+import Distribution.PackageDescription as Cabal (PackageDescription(..), allBuildInfo, buildTools, pkgconfigDepends, extraLibs)+import Distribution.Version (VersionRange, anyVersion, foldVersionRange', intersectVersionRanges, unionVersionRanges,+                             laterVersion, orLaterVersion, earlierVersion, orEarlierVersion, fromVersionIntervals, toVersionIntervals, withinVersion,+                             isNoVersion, asVersionIntervals)+import Distribution.Version.Invert (invertVersionRange)+import Prelude hiding (unlines)+import System.Exit (ExitCode(ExitSuccess))+import System.IO.Unsafe (unsafePerformIO)+import System.Process (readProcessWithExitCode)+import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))++data Dependency_+  = BuildDepends Dependency+  | BuildTools Dependency+  | PkgConfigDepends Dependency+  | ExtraLibs D.BinPkgName+    deriving (Eq, Show)++-- | In cabal a self dependency probably means the library is needed+-- while building the executables.  In debian it would mean that the+-- package needs an earlier version of itself to build, so we use this+-- to filter such dependencies out.+selfDependency :: PackageIdentifier -> Dependency_ -> Bool+selfDependency pkgId (BuildDepends (Dependency name _)) = name == pkgName pkgId+selfDependency _ _ = False++unboxDependency :: Dependency_ -> Maybe Dependency+unboxDependency (BuildDepends d) = Just d+unboxDependency (BuildTools d) = Just d+unboxDependency (PkgConfigDepends d) = Just d+unboxDependency (ExtraLibs _) = Nothing -- Dependency (PackageName d) anyVersion++-- Make a list of the debian devel packages corresponding to cabal packages+-- which are build dependencies+debDeps :: DebType -> Atoms -> Control' String -> D.Relations+debDeps debType atoms control =+    interdependencies ++ otherdependencies+    where+      interdependencies =+          case debType of+            Prof -> maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) (debNameFromType control Dev)+            _ -> []+      otherdependencies =+          catMaybes (map (\ (Dependency name _) ->+                          case Map.lookup name (getL packageInfo atoms) of+                            Just p -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (case debType of+                                                                                                             Dev -> devDeb p+                                                                                                             Prof -> profDeb p+                                                                                                             Doc -> docDeb p)+                            Nothing -> Nothing) (cabalDependencies atoms))++cabalDependencies :: Atoms -> [Dependency]+cabalDependencies atoms =+    catMaybes $ map unboxDependency $ allBuildDepends atoms+                  (Cabal.buildDepends (fromMaybe (error "cabalDependencies") $ getL packageDescription atoms))+                  (concatMap buildTools . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms)+                  (concatMap pkgconfigDepends . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms)+                  (concatMap extraLibs . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms)++-- |Debian packages don't have per binary package build dependencies,+-- so we just gather them all up here.+allBuildDepends :: Atoms -> [Dependency] -> [Dependency] -> [Dependency] -> [String] -> [Dependency_]+allBuildDepends atoms buildDepends buildTools pkgconfigDepends extraLibs =+    nub $ map BuildDepends buildDepends +++          map BuildTools buildTools +++          map PkgConfigDepends pkgconfigDepends +++          map ExtraLibs (fixDeps extraLibs)+    where+      fixDeps :: [String] -> [D.BinPkgName]+      fixDeps xs = concatMap (\ cab -> maybe [D.BinPkgName ("lib" ++ cab ++ "-dev")] Set.toList (Map.lookup cab (getL extraLibMap atoms))) xs++putBuildDeps :: Atoms -> Atoms+putBuildDeps deb =+    modL control (\ y -> y { Debian.buildDepends = debianBuildDeps deb, buildDependsIndep = debianBuildDepsIndep deb }) deb++-- The haskell-cdbs package contains the hlibrary.mk file with+-- the rules for building haskell packages.+debianBuildDeps :: Atoms -> D.Relations+debianBuildDeps deb =+    filterMissing deb $+    nub $ [[D.Rel (D.BinPkgName "debhelper") (Just (D.GRE (parseDebianVersion ("7.0" :: String)))) Nothing],+           [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))) +++            (if getL noProfilingLibrary deb then [] else [anyrel "ghc-prof"]) +++            cabalDeps (getL packageDescription deb)+    where+      cabalDeps Nothing = []+      cabalDeps (Just pkgDesc) =+          (concat $ map (buildDependencies deb)+                  $ filter (not . selfDependency (Cabal.package pkgDesc))+                  $ allBuildDepends+                          deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc)+                          (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc)+                          (concatMap extraLibs . allBuildInfo $ pkgDesc))++debianBuildDepsIndep :: Atoms -> D.Relations+debianBuildDepsIndep deb =+    filterMissing deb $+    if getL noDocumentationLibrary deb+    then []+    else nub $ [anyrel "ghc-doc"] +++               (map anyrel' (Set.toList (getL buildDepsIndep deb))) +++               cabalDeps (getL packageDescription deb)+    where+      cabalDeps Nothing = []+      cabalDeps (Just pkgDesc) =+          (concat . map (docDependencies deb)+                      $ filter (not . selfDependency (Cabal.package pkgDesc))+                      $ allBuildDepends+                            deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc)+                            (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc))++-- | The documentation dependencies for a package include the+-- documentation package for any libraries which are build+-- dependencies, so we have access to all the cross references.+docDependencies :: Atoms -> Dependency_ -> D.Relations+docDependencies atoms (BuildDepends (Dependency name ranges)) =+    dependencies atoms Documentation name ranges+docDependencies _ _ = []++-- | The Debian build dependencies for a package include the profiling+-- libraries and the documentation packages, used for creating cross+-- references.  Also the packages associated with extra libraries.+buildDependencies :: Atoms -> Dependency_ -> D.Relations+buildDependencies atoms (BuildDepends (Dependency name ranges)) =+    dependencies atoms Development name ranges +++    dependencies atoms Profiling name ranges+buildDependencies atoms dep@(ExtraLibs _) =+    concat (map dependency $ adapt (getL execMap atoms) dep)+buildDependencies atoms dep =+    case unboxDependency dep of+      Just (Dependency _name _ranges) ->+          concat (map dependency $ adapt (getL execMap atoms) dep)+      Nothing ->+          []++dependency :: D.BinPkgName -> D.Relations+dependency name = [[D.Rel name Nothing Nothing]]++adapt :: Map.Map String D.BinPkgName -> Dependency_ -> [D.BinPkgName]+adapt execMap (PkgConfigDepends (Dependency (PackageName pkg) _)) =+    maybe (aptFile pkg) (: []) (Map.lookup pkg execMap)+adapt execMap (BuildTools (Dependency (PackageName pkg) _)) =+    maybe (aptFile pkg) (: []) (Map.lookup pkg execMap)+adapt _flags (ExtraLibs x) = [x]+adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [D.BinPkgName pkg]++-- There are two reasons this may not work, or may work+-- incorrectly: (1) the build environment may be a different+-- distribution than the parent environment (the environment the+-- autobuilder was run from), so the packages in that+-- environment might have different names, and (2) the package+-- we are looking for may not be installed in the parent+-- environment.+aptFile :: String -> [D.BinPkgName] -- Maybe would probably be more correct+aptFile pkg =+    unsafePerformIO $+    do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] ""+       return $ case ret of+                  (ExitSuccess, out, _) ->+                      case takeWhile (not . isSpace) out of+                        "" -> error $ "Unable to locate a package containing " ++ pkg ++ ", try using --exec-map " ++ pkg ++ "=<debname> or Map.insert " ++ show pkg ++ " (BinPkgName \"<debname>\") (execMap flags)"+                        s -> [D.BinPkgName s]+                  _ -> []++anyrel :: String -> [D.Relation]+anyrel x = anyrel' (D.BinPkgName x)++anyrel' :: D.BinPkgName -> [D.Relation]+anyrel' x = [D.Rel x Nothing Nothing]++-- | Turn a cabal dependency into debian dependencies.  The result+-- needs to correspond to a single debian package to be installed,+-- so we will return just an OrRelation.+dependencies :: Atoms -> PackageType -> PackageName -> VersionRange -> Relations+dependencies atoms typ name cabalRange =+    map doBundled $ convert' (canonical (Or (catMaybes (map convert alts))))+    where++      -- Compute a list of alternative debian dependencies for+      -- satisfying a cabal dependency.  The only caveat is that+      -- 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+               -- 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')++      convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation)+      convert (dname, range) =+          if isNoVersion range'''+          then Nothing+          else Just $+               foldVersionRange'+                 (Rel (D.Rel dname Nothing Nothing))+                 (\ v -> Rel (D.Rel dname (Just (D.EEQ (dv v))) Nothing))+                 (\ v -> Rel (D.Rel dname (Just (D.SGR (dv v))) Nothing))+                 (\ v -> Rel (D.Rel dname (Just (D.SLT (dv v))) Nothing))+                 (\ v -> Rel (D.Rel dname (Just (D.GRE (dv v))) Nothing))+                 (\ v -> Rel (D.Rel dname (Just (D.LTE (dv v))) Nothing))+                 (\ x y -> And [Rel (D.Rel dname (Just (D.GRE (dv x))) Nothing), Rel (D.Rel dname (Just (D.SLT (dv y))) Nothing)])+                 (\ x y -> Or [x, y])+                 (\ x y -> And [x, y])+                 id+                 range'''+          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+            range'' = canon (unionVersionRanges range' (invertVersionRange range))+            -- Restrict the range to the versions specified for this debian package+            range' = intersectVersionRanges cabalRange' range+            -- When we see a cabal equals dependency we need to turn it into+            -- a wildcard because the resulting debian version numbers have+            -- various suffixes added.+      cabalRange' =+          foldVersionRange'+            anyVersion+            withinVersion  -- <- Here we are turning equals into wildcard+            laterVersion+            earlierVersion+            orLaterVersion+            orEarlierVersion+            (\ lb ub -> intersectVersionRanges (orLaterVersion lb) (earlierVersion ub))+            unionVersionRanges+            intersectVersionRanges+            id+            cabalRange+      -- Convert a cabal version to a debian version, adding an epoch number if requested+      dv v = parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (getL epochMap atoms)) ++ showVersion v)+      simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2]+      -- Simplify a VersionRange+      canon = fromVersionIntervals . toVersionIntervals++      -- If a package is bundled with the compiler we make the+      -- compiler a substitute for that package.  If we were to+      -- specify the virtual package (e.g. libghc-base-dev) we would+      -- have to make sure not to specify a version number.+      doBundled :: [D.Relation] -> [D.Relation]+      doBundled rels | ghcBuiltIn (fromMaybe (error "dependencies") $ getL compiler atoms) name = rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing]+      doBundled rels = rels++      compilerPackageName Documentation = D.BinPkgName "ghc-doc"+      compilerPackageName Profiling = D.BinPkgName "ghc-prof"+      compilerPackageName Development = D.BinPkgName "ghc"+      compilerPackageName _ = D.BinPkgName "ghc" -- whatevs++data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel {unRel :: a} deriving Show++convert' :: Rels a -> [[a]]+convert' = map (map unRel . unOr) . unAnd . canonical++-- | return and of ors of rel+canonical :: Rels a -> Rels a+canonical (Rel rel) = And [Or [Rel rel]]+canonical (And rels) = And $ concatMap (unAnd . canonical) rels+canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels++-- | 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+    where+      foldTriples' :: (PackageName -> Version -> PackageName -> PackageName -> PackageName) -> PackageName -> VersionSplits -> PackageName+      foldTriples' = foldTriples+      -- def = mkPkgName pname typ+      pname@(PackageName string) = pkgName pkgDesc+      version = (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion pkgDesc)))))++-- | Given a control file and a DebType, look for the binary deb with+-- the corresponding suffix and return its name.+debNameFromType :: Control' String -> DebType -> Maybe BinPkgName+debNameFromType control debType =+    case debType of+      Dev -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-dev") debNames)+      Prof -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-prof") debNames)+      Doc -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-doc") debNames)+    where+      debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control))))++-- | Build a debian package name from a cabal package name and a+-- debian package type.  Unfortunately, this does not enforce the+-- correspondence between the PackageType value and the name type, so+-- it can return nonsense like (SrcPkgName "libghc-debian-dev").+mkPkgName :: PkgName name => PackageName -> PackageType -> name+mkPkgName (PackageName name) typ =+    pkgNameFromString $+             case typ of+                Documentation -> "libghc-" ++ base ++ "-doc"+                Development -> "libghc-" ++ base ++ "-dev"+                Profiling -> "libghc-" ++ base ++ "-prof"+                Utilities -> "haskell-" ++ base ++ "-utils"+                Exec -> base+                Source' -> "haskell-" ++ base ++ ""+                Cabal -> base+    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+cdbsRules pkgId deb =+    setL rulesHead+         (Just . unlines $+          ["#!/usr/bin/make -f",+           "",+           "DEB_CABAL_PACKAGE = " <> name,+           "",+           "include /usr/share/cdbs/1/rules/debhelper.mk",+           "include /usr/share/cdbs/1/class/hlibrary.mk" ])+         deb+    where+      -- The name is based on the cabal package, but it may need to be+      -- modified to avoid violating Debian rules - no underscores, no+      -- capital letters.+      name = pack (show (pretty (debianName deb Cabal pkgId :: BinPkgName)))+-}++getRulesHead :: Atoms -> Text+getRulesHead atoms =+    fromMaybe computeRulesHead (getL rulesHead atoms)+    where+      computeRulesHead =+          unlines $+            ["#!/usr/bin/make -f", ""] +++            maybe [] (\ x -> ["DEB_CABAL_PACKAGE = " <> x, ""]) (fmap name (getL packageDescription atoms)) +++            ["include /usr/share/cdbs/1/rules/debhelper.mk",+             "include /usr/share/cdbs/1/class/hlibrary.mk"]+      name pkgDesc = pack (show (pretty (debianName atoms Cabal (Cabal.package pkgDesc) :: BinPkgName)))++filterMissing :: Atoms -> [[Relation]] -> [[Relation]]+filterMissing atoms rels =+    filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name (getL missingDependencies atoms)))) rels)++binaryPackageDeps :: BinPkgName -> Atoms -> [[Relation]]+binaryPackageDeps b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL depends atoms))++binaryPackageConflicts :: BinPkgName -> Atoms -> [[Relation]]+binaryPackageConflicts b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL conflicts atoms))
+ src/Debian/Debianize/Files.hs view
@@ -0,0 +1,199 @@+-- | Convert a Debianization into a list of files that can then be+-- written out.+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TupleSections #-}+module Debian.Debianize.Files+    ( toFileMap+    ) where++import Data.Lens.Lazy (getL)+import Data.List as List (map, unlines)+import Data.Map as Map (Map, toList, fromListWithKey, mapKeys)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Set as Set (toList, member)+import Data.Text as Text (Text, pack, unpack, lines, unlines, strip, null)+import Debian.Control (Control'(Control, unControl), Paragraph'(Paragraph), Field'(Field))+import Debian.Debianize.Atoms (Atoms, compat, sourceFormat, watch, changelog, control, postInst, postRm, preInst, preRm,+                               intermediateFiles, install, installDir, installInit, logrotateStanza, link,+                               rulesHead, rulesFragments, copyright)+import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..),+                                               VersionControlSpec(..), XField(..), XFieldDest(..))+import Debian.Debianize.Dependencies (getRulesHead)+import Debian.Debianize.Utility (showDeps')+import Debian.Relation (Relations, BinPkgName(BinPkgName))+import Prelude hiding (init, unlines, writeFile)+import System.FilePath ((</>))+import Text.PrettyPrint.ANSI.Leijen (pretty)++sourceFormatFiles :: Atoms -> [(FilePath, Text)]+sourceFormatFiles deb = maybe [] (\ x -> [("debian/source/format", pack (show (pretty x)))]) (getL sourceFormat deb)++watchFile :: Atoms -> [(FilePath, Text)]+watchFile deb = maybe [] (\ x -> [("debian/watch", x)]) (getL watch deb)++intermediates :: Atoms -> [(FilePath, Text)]+intermediates deb = Set.toList $ getL intermediateFiles deb++installs :: Atoms -> [(FilePath, Text)]+installs deb =+    map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (src, dst) -> src <> " " <> dst) (Set.toList pairs))))) $+    Map.toList $+    mapKeys pathf $+    getL install deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".install"++dirs :: Atoms -> [(FilePath, Text)]+dirs 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"++init :: Atoms -> [(FilePath, Text)]+init deb =+    Map.toList $ mapKeys pathf $ getL installInit deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".init"++-- FIXME - use a map and insertWith, check for multiple entries+logrotate :: Atoms -> [(FilePath, Text)]+logrotate deb =+    map (\ (path, stanzas) -> (path, Text.unlines (Set.toList stanzas))) $ Map.toList $ mapKeys pathf $ getL logrotateStanza deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".logrotate"++-- | Assemble all the links by package and output one file each+links :: Atoms -> [(FilePath, Text)]+links deb =+    map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (loc, txt) -> loc ++ " " ++ txt) (Set.toList pairs))))) $+    Map.toList $+    mapKeys pathf $+    getL link deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".links"++postinstFiles :: Atoms -> [(FilePath, Text)]+postinstFiles deb =+    Map.toList $ mapKeys pathf $ getL postInst deb+    where+      pathf (BinPkgName name) = "debian" </> show (pretty name) ++ ".postinst"++postrmFiles :: Atoms -> [(FilePath, Text)]+postrmFiles deb =+    Map.toList $ mapKeys pathf $ getL postRm deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".postrm"++preinstFiles :: Atoms -> [(FilePath, Text)]+preinstFiles deb =+    Map.toList $ mapKeys pathf $ getL preInst deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".preinst"++prermFiles :: Atoms -> [(FilePath, Text)]+prermFiles deb =+    Map.toList $ mapKeys pathf $ getL preRm deb+    where+      pathf name = "debian" </> show (pretty name) ++ ".prerm"++-- | Turn the Debianization into a list of files, making sure the text+-- associated with each path is unique.  Assumes that+-- finalizeDebianization has already been called.  (Yes, I'm+-- considering building one into the other, but it is handy to look at+-- the Debianization produced by finalizeDebianization in the unit+-- tests.)+toFileMap :: Atoms -> Map FilePath Text+toFileMap atoms =+    Map.fromListWithKey (\ k a b -> error $ "Multiple values for " ++ k ++ ":\n  " ++ show a ++ "\n" ++ show b) $+      [("debian/control", pack (show (pretty (controlFile d)))),+       ("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))] +++      sourceFormatFiles atoms +++      watchFile atoms +++      installs atoms +++      dirs atoms +++      init atoms +++      logrotate atoms +++      links atoms +++      postinstFiles atoms +++      postrmFiles atoms +++      preinstFiles atoms +++      prermFiles atoms +++      intermediates atoms+    where d = getL control atoms++rules :: Atoms -> Text+rules deb = Text.unlines (maybe (getRulesHead deb) id (getL rulesHead deb) : reverse (Set.toList (getL rulesFragments deb)))++controlFile :: SourceDebDescription -> Control' String+controlFile src =+    Control+    { unControl =+          (Paragraph+           ([Field ("Source", " " ++ show (pretty (source src))),+             Field ("Maintainer", " " <> show (pretty (maintainer src)))] +++            lField "Uploaders" (uploaders src) +++            (case dmUploadAllowed src of True -> [Field ("DM-Upload-Allowed", " yes")]; False -> []) +++            mField "Priority" (priority src) +++            mField "Section" (section src) +++            depField "Build-Depends" (buildDepends src) +++            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 "Homepage" (homepage src) +++            List.map vcsField (Set.toList (vcsFields src)) +++            List.map xField (Set.toList (xFields src))) :+           List.map binary (binaryPackages src))+    }+    where+      binary :: BinaryDebDescription -> Paragraph' String+      binary bin =+          Paragraph+           ([Field ("Package", " " ++ show (pretty (package bin))),+             Field ("Architecture", " " ++ show (pretty (architecture bin)))] +++            mField "Section" (binarySection bin) +++            mField "Priority" (binaryPriority bin) +++            bField "Essential" (essential bin) +++            relFields (relations bin) +++            [Field ("Description", " " ++ unpack (ensureDescription (description bin)))])+          where+            ensureDescription t =+                case Text.lines t of+                  [] -> "No description available."+                  (short : long) | Text.null (strip short) -> Text.unlines ("No short description available" : long)+                  _ -> t+      mField tag = maybe [] (\ x -> [Field (tag, " " <> show (pretty x))])+      bField tag flag = if flag then [Field (tag, " yes")] else []+      lField _ [] = []+      lField tag xs = [Field (tag, " " <> show (pretty xs))]+      vcsField (VCSBrowser t) = Field ("Vcs-Browser", " " ++ unpack t)+      vcsField (VCSArch t) = Field ("Vcs-Arch", " " ++ unpack t)+      vcsField (VCSBzr t) = Field ("Vcs-Bzr", " " ++ unpack t)+      vcsField (VCSCvs t) = Field ("Vcs-Cvs", " " ++ unpack t)+      vcsField (VCSDarcs t) = Field ("Vcs-Darcs", " " ++ unpack t)+      vcsField (VCSGit t) = Field ("Vcs-Git", " " ++ unpack t)+      vcsField (VCSHg t) = Field ("Vcs-Hg", " " ++ unpack t)+      vcsField (VCSMtn t) = Field ("Vcs-Mtn", " " ++ unpack t)+      vcsField (VCSSvn t) = Field ("Vcs-Svn", " " ++ unpack t)+      xField (XField dests tag t) = Field (unpack ("X" <> showDests dests <> "-" <> tag), unpack (" " <> t))+      showDests s = if member B s then "B" else "" <>+                    if member S s then "S" else "" <>+                    if member C s then "C" else ""++relFields :: PackageRelations -> [Field' [Char]]+relFields rels =+    depField "Depends" (depends rels) +++    depField "Recommends" (recommends rels) +++    depField "Suggests" (suggests rels) +++    depField "Pre-Depends" (preDepends rels) +++    depField "Breaks" (breaks rels) +++    depField "Conflicts" (conflicts rels) +++    depField "Provides" (provides rels) +++    depField "Replaces" (replaces rels) +++    depField "Built-Using" (builtUsing rels)++depField :: [Char] -> Relations -> [Field' [Char]]+depField tag rels = case rels of [] -> []; _ -> [Field (tag, " " ++ showDeps' (tag ++ ":") rels)]
+ src/Debian/Debianize/Finalize.hs view
@@ -0,0 +1,301 @@+-- | Convert a Debianization into a list of files that can then be+-- written out.+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Debian.Debianize.Finalize+    ( finalizeDebianization+    ) where++import Data.ByteString.Lazy.UTF8 (fromString)+import Data.Char (toLower)+import Data.Digest.Pure.MD5 (md5)+import Data.Lens.Lazy (setL, getL, modL)+import Data.List as List (map)+import Data.Map as Map (insertWith, foldWithKey, elems)+import Data.Maybe+import Data.Monoid (mempty, (<>))+import Data.Set as Set (Set, difference, fromList, null, insert, toList, filter, fold, map, union, singleton)+import Data.Text as Text (pack, unlines, unpack)+import Debian.Debianize.Atoms as Atoms+    (Atoms, packageDescription, control, binaryArchitectures, rulesFragments, website, serverInfo, link,+     backups, executable, sourcePriority, sourceSection, binaryPriorities, binarySections, description,+     install, installTo, installData, installCabalExecTo, noProfilingLibrary, noDocumentationLibrary,+     utilsPackageName, extraDevDeps, installData, installCabalExec, file, apacheSite, installDir, buildDir,+     dataDir, intermediateFiles)+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.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 System.FilePath ((</>), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName)+import Text.PrettyPrint.ANSI.Leijen (pretty)++-- | Now that we know the build and data directories, we can expand+-- some atoms into sets of simpler atoms which can eventually be+-- turned into the files of the debianization.  The original atoms are+-- not removed from the list because they may contribute to the+-- 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 deb0 =+    deb'''''+    where+      -- Fixme - makeUtilsPackage does stuff that needs to go through foldAtomsFinalized+      deb' = finalizeAtoms deb0+      deb'' = f deb'+      deb''' = makeUtilsPackage $ librarySpecs $ putBuildDeps $ deb''+      deb'''' = finalizeAtoms deb'''+      deb''''' = g deb'''' -- Apply tweaks to the debianization++      -- Create the binary packages+      f :: Atoms -> Atoms+      f atoms = (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL website atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL serverInfo atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> modL binaryArchitectures (Map.insertWith (flip const) b Any) . cabalExecBinaryPackage b $ atoms'') atoms' (getL backups atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL executable atoms)) $ atoms+      -- Apply the hints in the atoms to the debianization+      g :: Atoms -> Atoms+      g atoms = (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {priority = Just x}) atoms') (getL sourcePriority atoms)) .+                (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {section = Just x}) atoms') (getL sourceSection atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {architecture = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryArchitectures atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binaryPriority = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryPriorities atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binarySection = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binarySections atoms)) .+                (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {Debian.description = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL Atoms.description atoms)) $ atoms++cabalExecBinaryPackage :: BinPkgName -> Atoms -> Atoms+cabalExecBinaryPackage b deb =+    modL control (\ y -> y {binaryPackages = bin : binaryPackages y}) deb+    where+      bin = BinaryDebDescription+            { Debian.package = b+            , architecture = Any+            , binarySection = Just (MainSection "misc")+            , binaryPriority = Nothing+            , essential = False+            , Debian.description = describe deb Exec (Cabal.package pkgDesc)+            , relations = binaryPackageRelations b Exec deb+            }+      pkgDesc = fromMaybe (error "cabalExecBinaryPackage: no PackageDescription") $ getL packageDescription deb++binaryPackageRelations :: BinPkgName -> PackageType -> Atoms -> PackageRelations+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 []) +++                       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 = []+    , builtUsing = []+    }++-- debLibProf haddock binaryPackageDeps extraDevDeps extraLibMap+librarySpecs :: Atoms -> Atoms+librarySpecs deb | isNothing (getL packageDescription deb) = deb+librarySpecs deb =+    (if doc+     then modL link (Map.insertWith Set.union debName (singleton ("/usr/share/doc" </> show (pretty debName) </> "html" </> cabal <.> "txt", "/usr/lib/ghc-doc/hoogle" </> hoogle <.> "txt")))+     else id) $+    modL control+         (\ y -> y { binaryPackages =+                               (if dev then [librarySpec deb Any Development (Cabal.package pkgDesc)] else []) +++                               (if prof then [librarySpec deb Any Profiling (Cabal.package pkgDesc)] else []) +++                               (if doc then [docSpecsParagraph deb (Cabal.package pkgDesc)] else []) +++                               (binaryPackages y) })+         deb+    where+      doc = dev && not (getL noDocumentationLibrary deb)+      prof = dev && not (getL noProfilingLibrary deb)+      dev = isJust (Cabal.library pkgDesc)+      pkgDesc = fromMaybe (error "librarySpecs: no PackageDescription") $ getL packageDescription deb+      PackageName cabal = pkgName (Cabal.package pkgDesc)+      debName :: BinPkgName+      debName = debianName deb Documentation (Cabal.package pkgDesc)+      hoogle = List.map toLower cabal++docSpecsParagraph :: Atoms -> PackageIdentifier -> BinaryDebDescription+docSpecsParagraph atoms pkgId =+          BinaryDebDescription+            { Debian.package = debianName atoms Documentation pkgId+            , architecture = All+            , binarySection = Just (MainSection "doc")+            , binaryPriority = Nothing+            , essential = False+            , Debian.description = describe atoms Documentation pkgId+            , relations = binaryPackageRelations (debianName atoms Documentation pkgId) Development atoms+            }++librarySpec :: Atoms -> PackageArchitectures -> PackageType -> PackageIdentifier -> BinaryDebDescription+librarySpec atoms arch typ pkgId =+          BinaryDebDescription+            { Debian.package = debianName atoms typ pkgId+            , architecture = arch+            , binarySection = Nothing+            , binaryPriority = Nothing+            , essential = False+            , Debian.description = describe atoms typ pkgId+            , relations = binaryPackageRelations (debianName atoms typ pkgId) Development atoms+            }++-- | Create a package to hold any executables and data files not+-- assigned to some other package.+makeUtilsPackage :: Atoms -> Atoms+makeUtilsPackage deb | isNothing (getL packageDescription deb) = deb+makeUtilsPackage deb =+    case (Set.difference availableData installedData, Set.difference availableExec installedExec) of+      (datas, execs) | Set.null datas && Set.null execs -> deb+      (datas, execs) ->+          let p = fromMaybe (debianName deb Utilities (Cabal.package pkgDesc)) (getL utilsPackageName deb)+              deb' = setL packageDescription (Just pkgDesc) . makeUtilsAtoms p datas execs $ deb in+          modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb'+    where+      f _ _ _ (Just bin) = bin+      f deb' p arch Nothing =+          let bin = newBinaryDebDescription p arch in+          bin {binarySection = Just (MainSection "misc"),+               relations = binaryPackageRelations p Utilities deb'}+      pkgDesc = fromMaybe (error "makeUtilsPackage: no PackageDescription") $ getL packageDescription deb+      availableData = Set.fromList (Cabal.dataFiles pkgDesc)+      availableExec = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc)))+      installedData :: Set FilePath+      installedData = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL install deb) <>+                                    (List.map fst . concat . List.map toList . elems $ getL installTo deb) <>+                                    (List.map fst . concat . List.map toList . elems $ getL installData deb))+      installedExec :: Set String+      installedExec = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL installCabalExec deb) <>+                                    (List.map fst . concat . List.map toList .  elems $ getL installCabalExecTo deb) <>+                                    (List.map ename . elems $ getL executable deb))+          where ename i =+                    case sourceDir i of+                      (Nothing) -> execName i+                      (Just s) ->  s </> execName i+      -- installedExec = foldCabalExecs (Set.insert :: String -> Set String -> Set String) (Set.empty :: Set String) deb++makeUtilsAtoms :: BinPkgName -> Set FilePath -> Set String -> Atoms -> Atoms+makeUtilsAtoms p datas execs atoms0 =+    if Set.null datas && Set.null execs+    then atoms0+    else modL rulesFragments (Set.insert (pack ("build" </> show (pretty p) ++ ":: build-ghc-stamp\n"))) . g $ atoms0+    where+      g :: Atoms -> Atoms+      g atoms = Set.fold execAtom (Set.fold dataAtom atoms datas) execs+      dataAtom path atoms = modL installData (insertWith union p (singleton (path, path))) atoms+      execAtom name atoms = modL installCabalExec (insertWith union p (singleton (name, "usr/bin"))) atoms++anyrel :: String -> [Relation]+anyrel x = anyrel' (BinPkgName x)++anyrel' :: BinPkgName -> [Relation]+anyrel' x = [Rel x Nothing Nothing]++finalizeAtoms :: Atoms -> Atoms+finalizeAtoms atoms | atoms == mempty = atoms+finalizeAtoms atoms = atoms <> finalizeAtoms (expandAtoms atoms)++expandAtoms :: Atoms -> Atoms+expandAtoms old =+    expandApacheSite .+    expandInstallCabalExec .+    expandInstallCabalExecTo .+    expandInstallData .+    expandInstallTo .+    expandFile .+    expandWebsite .+    expandServer .+    expandBackups .+    expandExecutable $+    mempty+    where+      expandApacheSite :: Atoms -> Atoms+      expandApacheSite new =+          foldWithKey (\ b (dom, log, text) atoms ->+                           modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom))) .+                           modL installDir (Map.insertWith Set.union b (singleton log)) .+                           modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" </> dom, text))) $+                           atoms)+                      new+                      (getL apacheSite old)++      expandInstallCabalExec :: Atoms -> Atoms+      expandInstallCabalExec new =+          foldWithKey (\ b pairs atoms -> Set.fold (\ (name, dst) atoms' -> modL install (Map.insertWith Set.union b (singleton (builddir </> name </> name, dst))) atoms')+                                                    atoms+                                                    pairs)+                      new+                      (getL installCabalExec old)+          where+            builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old)++      expandInstallCabalExecTo :: Atoms -> Atoms+      expandInstallCabalExecTo new =+          foldWithKey (\ b pairs atoms ->+                           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')+                                    atoms+                                    pairs)+                      new+                      (getL installCabalExecTo old)+          where+            builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old)++      expandInstallData :: Atoms -> Atoms+      expandInstallData new =+          foldWithKey (\ b pairs atoms ->+                           Set.fold (\ (s, d) atoms' ->+                                         if takeFileName s == takeFileName d+                                         then modL install (Map.insertWith Set.union b (singleton (s, datadir </> makeRelative "/" (takeDirectory d)))) atoms'+                                         else modL installTo (Map.insertWith Set.union b (singleton (s, datadir </> makeRelative "/" d))) atoms')+                                    atoms+                                    pairs)+                      new+                      (getL installData old)+          where+            datadir = fromMaybe (error "finalizeAtoms: no dataDir") $ getL dataDir old++      expandInstallTo :: Atoms -> Atoms+      expandInstallTo new =+          foldWithKey (\ p pairs atoms ->+                           Set.fold (\ (s, d) atoms' ->+                                         modL rulesFragments (Set.insert (Text.unlines+                                                                          [ pack ("binary-fixup" </> show (pretty p)) <> "::"+                                                                          , "\tinstall -Dp " <> pack s <> " " <> pack ("debian" </> show (pretty p) </> makeRelative "/" d) ])) atoms') atoms pairs)+                      new+                      (getL installTo old)++      expandFile :: Atoms -> Atoms+      expandFile new =+          foldWithKey (\ p pairs atoms ->+                           Set.fold (\ (path, s) atoms' ->+                                         let (destDir', destName') = splitFileName path+                                             tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack s)))+                                             tmpPath = tmpDir </> destName' in+                                         modL intermediateFiles (Set.insert (tmpPath, s)) .+                                         modL install (Map.insertWith Set.union p (singleton (tmpPath, destDir'))) $+                                         atoms')+                                    atoms+                                    pairs)+                      new+                      (getL file old)++      expandWebsite :: Atoms -> Atoms+      expandWebsite new = foldWithKey siteAtoms new (getL website old)++      expandServer :: Atoms -> Atoms+      expandServer new = foldWithKey (\ b x atoms -> serverAtoms b x False atoms) new (getL serverInfo old)++      expandBackups :: Atoms -> Atoms+      expandBackups new = foldWithKey backupAtoms new (getL backups old)++      expandExecutable :: Atoms -> Atoms+      expandExecutable new = foldWithKey execAtoms new (getL executable old)
+ src/Debian/Debianize/Generic.hs view
@@ -0,0 +1,108 @@+-- | 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))
+ src/Debian/Debianize/Goodies.hs view
@@ -0,0 +1,376 @@+-- | Things that seem like they could be clients of this library, but+-- are instead included as part of the library.+{-# LANGUAGE OverloadedStrings #-}+module Debian.Debianize.Goodies+    ( defaultAtoms+    , tightDependencyFixup+    , doServer+    , doWebsite+    , doBackups+    , doExecutable+    , debianDescription+    , describe+    , watchAtom+    , oldClckwrksSiteFlags+    , oldClckwrksServerFlags+    , siteAtoms+    , serverAtoms+    , backupAtoms+    , execAtoms+    ) where++import Data.Lens.Lazy (getL, setL, modL)+import Data.List as List (map, intersperse, intercalate)+import Data.Map as Map (Map, fromList, insertWith)+import Data.Maybe (fromMaybe)+import Data.Monoid (mempty, (<>))+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)+import Debian.Debianize.ControlFile as Debian (PackageType(..))+import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), VersionSplits(..))+import Debian.Debianize.Utility (trim)+import Debian.Orphans ()+import Debian.Policy (apacheLogDirectory, apacheErrorLog, apacheAccessLog, databaseDirectory, serverAppLog, serverAccessLog)+import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel))+import Distribution.Package (PackageIdentifier(..), PackageName(PackageName))+import qualified Distribution.PackageDescription as Cabal+import Distribution.Text (display)+import Prelude hiding (writeFile, init, unlines, log, map)+import System.FilePath ((</>))+import System.Process (showCommandForUser)+import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))++-- | 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)]++-- | 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,+-- and another that makes P conflict with any older version of A.+tightDependencyFixup :: [(BinPkgName, BinPkgName)] -> BinPkgName -> Atoms -> Atoms+tightDependencyFixup [] _ deb = deb+tightDependencyFixup pairs p deb =+    modL rulesFragments+             (Set.insert+              (Text.unlines $+               ([ "binary-fixup/" <> name <> "::"+                , "\techo -n 'haskell:Depends=' >> debian/" <> name <> ".substvars" ] +++                intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map equals pairs) +++                [ "\techo '' >> debian/" <> name <> ".substvars"+                , "\techo -n 'haskell:Conflicts=' >> debian/" <> name <> ".substvars" ] +++                intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map newer pairs) +++                [ "\techo '' >> debian/" <> name <> ".substvars" ]))) deb+    where+      equals (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (=$${Version})' " <>  display' installed <> " >> debian/" <> name <> ".substvars"+      newer  (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (>>$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars"+      name = display' p+      display' = pack . show . pretty++-- | Add a debian binary package to the debianization containing a cabal executable file.+doExecutable :: BinPkgName -> InstallFile -> Atoms -> Atoms+doExecutable bin x deb = modL executable (Map.insertWith (error "executable") bin x) deb++-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a server.+doServer :: BinPkgName -> Server -> Atoms -> Atoms+doServer bin x deb = modL serverInfo (Map.insertWith (error "serverInfo") bin x) deb++-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a web site.+doWebsite :: BinPkgName -> Site -> Atoms -> Atoms+doWebsite bin x deb = modL website (Map.insertWith (error "website") bin x) deb++-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a backup script.+doBackups :: BinPkgName -> String -> Atoms -> Atoms+doBackups bin s deb =+    modL backups (Map.insertWith (error "backups") bin s) $+    modL Atoms.depends (Map.insertWith union bin (singleton (Rel (BinPkgName "anacron") Nothing Nothing))) $+    deb++describe :: Atoms -> PackageType -> PackageIdentifier -> Text+describe atoms typ ident =+    debianDescription (Cabal.synopsis pkgDesc) (Cabal.description pkgDesc) (Cabal.author pkgDesc) (Cabal.maintainer pkgDesc) (Cabal.pkgUrl pkgDesc) typ ident+    where+      pkgDesc = fromMaybe (error $ "describe " ++ show ident) $ getL packageDescription atoms++debianDescription :: String -> String -> String -> String -> String -> PackageType -> PackageIdentifier -> Text+debianDescription synopsis' description' author' maintainer' url typ pkgId =+    debianDescriptionBase synopsis' description' author' maintainer' url <> "\n" <>+    case typ of+      Profiling ->+          Text.intercalate "\n"+                  [" .",+                   " This package provides a library for the Haskell programming language, compiled",+                   " for profiling.  See http:///www.haskell.org/ for more information on Haskell."]+      Development ->+          Text.intercalate "\n"+                  [" .",+                   " This package provides a library for the Haskell programming language.",+                   " See http:///www.haskell.org/ for more information on Haskell."]+      Documentation ->+          Text.intercalate "\n"+                  [" .",+                   " This package provides the documentation for a library for the Haskell",+                   " programming language.",+                   " See http:///www.haskell.org/ for more information on Haskell." ]+      Exec ->+          Text.intercalate "\n"+                  [" .",+                   " An executable built from the " <> pack (display (pkgName pkgId)) <> " package."]+{-    ServerPackage ->+          Text.intercalate "\n"+                  [" .",+                   " A server built from the " <> pack (display (pkgName pkgId)) <> " package."] -}+      Utilities ->+          Text.intercalate "\n"+                  [" .",+                   " Utility files associated with the " <> pack (display (pkgName pkgId)) <> " package."]+      x -> error $ "Unexpected library package name suffix: " ++ show x++-- | The Cabal package has one synopsis and one description field+-- for the entire package, while in a Debian package there is a+-- description field (of which the first line is synopsis) in+-- each binary package.  So the cabal description forms the base+-- of the debian description, each of which is amended.+debianDescriptionBase :: String -> String -> String -> String -> String -> Text+debianDescriptionBase synopsis' description' author' maintainer' url =+    (pack . unwords . words $ synopsis') <>+    case description' of+      "" -> ""+      text ->+          let text' = text ++ "\n" +++                      list "" ("\n Author: " ++) author' +++                      list "" ("\n Upstream-Maintainer: " ++) maintainer' +++                      list "" ("\n Url: " ++) url in+          "\n " <> (pack . trim . List.intercalate "\n " . List.map addDot . lines $ text')+    where+      addDot line = if all (flip elem " \t") line then "." else line+      list :: b -> ([a] -> b) -> [a] -> b+      list d f l = case l of [] -> d; _ -> f l++oldClckwrksSiteFlags :: Site -> [String]+oldClckwrksSiteFlags x =+    [ -- According to the happstack-server documentation this needs a trailing slash.+      "--base-uri", "http://" ++ domain x ++ "/"+    , "--http-port", show port]+oldClckwrksServerFlags :: Server -> [String]+oldClckwrksServerFlags x =+    [ -- According to the happstack-server documentation this needs a trailing slash.+      "--base-uri", "http://" ++ hostname x ++ ":" ++ show (port x) ++ "/"+    , "--http-port", show port]++watchAtom :: PackageName -> Text+watchAtom (PackageName pkgname) =+    pack $ "version=3\nopts=\"downloadurlmangle=s|archive/([\\w\\d_-]+)/([\\d\\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\\\nfilenamemangle=s|(.*)/$|" ++ pkgname +++           "-$1.tar.gz|\" \\\n    http://hackage.haskell.org/packages/archive/" ++ pkgname +++           " \\\n    ([\\d\\.]*\\d)/\n"++siteAtoms :: BinPkgName -> Site -> Atoms -> Atoms+siteAtoms b site =+    modL installDir (Map.insertWith Set.union b (singleton "/etc/apache2/sites-available")) .+    modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ domain site, "/etc/apache2/sites-enabled/" ++ domain site))) .+    modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" </> domain site, apacheConfig))) .+    modL installDir (Map.insertWith Set.union b (singleton (apacheLogDirectory b))) .+    modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $+                                                                 [ pack (apacheAccessLog b) <> " {"+                                                                 , "  weekly"+                                                                 , "  rotate 5"+                                                                 , "  compress"+                                                                 , "  missingok"+                                                                 , "}"]))) .+    modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $+                                                                 [ pack (apacheErrorLog b) <> " {"+                                                                 , "  weekly"+                                                                 , "  rotate 5"+                                                                 , "  compress"+                                                                 , "  missingok"+                                                                 , "}" ]))) .+    serverAtoms b (server site) True+    where+      -- An apache site configuration file.  This is installed via a line+      -- in debianFiles.+      apacheConfig =+          Text.unlines $+                   [  "<VirtualHost *:80>"+                   , "    ServerAdmin " <> pack (serverAdmin site)+                   , "    ServerName www." <> pack (domain site)+                   , "    ServerAlias " <> pack (domain site)+                   , ""+                   , "    ErrorLog " <> pack (apacheErrorLog b)+                   , "    CustomLog " <> pack (apacheAccessLog b) <> " combined"+                   , ""+                   , "    ProxyRequests Off"+                   , "    AllowEncodedSlashes NoDecode"+                   , ""+                   , "    <Proxy *>"+                   , "                AddDefaultCharset off"+                   , "                Order deny,allow"+                   , "                #Allow from .example.com"+                   , "                Deny from all"+                   , "                #Allow from all"+                   , "    </Proxy>"+                   , ""+                   , "    <Proxy http://127.0.0.1:" <> port' <> "/*>"+                   , "                AddDefaultCharset off"+                   , "                Order deny,allow"+                   , "                #Allow from .example.com"+                   , "                #Deny from all"+                   , "                Allow from all"+                   , "    </Proxy>"+                   , ""+                   , "    SetEnv proxy-sendcl 1"+                   , ""+                   , "    ProxyPass / http://127.0.0.1:" <> port' <> "/ nocanon"+                   , "    ProxyPassReverse / http://127.0.0.1:" <> port' <> "/"+                   , "</VirtualHost>" ]+      port' = pack (show (port (server site)))++serverAtoms :: BinPkgName -> Server -> Bool -> Atoms -> Atoms+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+      debianInit =+          Text.unlines $+                   [ "#! /bin/sh -e"+                   , ""+                   , ". /lib/lsb/init-functions"+                   , ""+                   , "case \"$1\" in"+                   , "  start)"+                   , "    test -x /usr/bin/" <> pack (destName exec) <> " || exit 0"+                   , "    log_begin_msg \"Starting " <> pack (destName exec) <> "...\""+                   , "    mkdir -p " <> pack (databaseDirectory b)+                   , "    " <> startCommand+                   , "    log_end_msg $?"+                   , "    ;;"+                   , "  stop)"+                   , "    log_begin_msg \"Stopping " <> pack (destName exec) <> "...\""+                   , "    " <> stopCommand+                   , "    log_end_msg $?"+                   , "    ;;"+                   , "  *)"+                   , "    log_success_msg \"Usage: ${0} {start|stop}\""+                   , "    exit 1"+                   , "esac"+                   , ""+                   , "exit 0" ]+      startCommand = pack $ showCommandForUser "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverOptions)+      stopCommand = pack $ showCommandForUser "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"]++      debianPostinst =+          Text.unlines $+                   ([ "#!/bin/sh"+                    , ""+                    , "case \"$1\" in"+                    , "  configure)" ] +++                    (if isSite+                     then [ "    # Apache won't start if this directory doesn't exist"+                          , "    mkdir -p " <> pack (apacheLogDirectory b)+                          , "    # Restart apache so it sees the new file in /etc/apache2/sites-enabled"+                          , "    /usr/sbin/a2enmod proxy"+                          , "    /usr/sbin/a2enmod proxy_http"+                          , "    service apache2 restart" ]+                     else []) +++                    [ "    service " <> pack (show (pretty b)) <> " start"+                    , "    ;;"+                    , "esac"+                    , ""+                    , "#DEBHELPER#"+                    , ""+                    , "exit 0" ])++-- | A configuration file for the logrotate facility, installed via a line+-- in debianFiles.+serverLogrotate' :: BinPkgName -> Atoms -> Atoms+serverLogrotate' b =+    modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {"+                                 , "  weekly"+                                 , "  rotate 5"+                                 , "  compress"+                                 , "  missingok"+                                 , "}" ]))) .+    modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {"+                                 , "  weekly"+                                 , "  rotate 5"+                                 , "  compress"+                                 , "  missingok"+                                 , "}" ])))++backupAtoms :: BinPkgName -> String -> Atoms -> Atoms+backupAtoms b name =+    modL postInst (insertWith (error "backupAtoms") b+                 (Text.unlines $+                  [ "#!/bin/sh"+                  , ""+                  , "case \"$1\" in"+                  , "  configure)"+                  , "    " <> pack ("/etc/cron.hourly" </> name) <> " --initialize"+                  , "    ;;"+                  , "esac" ])) .+    execAtoms b (InstallFile { execName = name+                              , destName = name+                              , sourceDir = Nothing+                              , destDir = Just "/etc/cron.hourly" })++execAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms+execAtoms b ifile r =+    modL rulesFragments (Set.insert (pack ("build" </> show (pretty b) ++ ":: build-ghc-stamp"))) .+    fileAtoms b ifile $+    r++fileAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms+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+    where+      d = fromMaybe "usr/bin" destDir
+ src/Debian/Debianize/Input.hs view
@@ -0,0 +1,315 @@+-- | Read an existing Debianization from a directory file.+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Debian.Debianize.Input+    ( inputDebianization+    , inputChangeLog+    , inputCabalization+    , inputCopyright+    , inputMaintainer+    ) where++import Debug.Trace (trace)++import Control.Exception (SomeException, catch, bracket)+import Control.Monad (when, foldM, filterM)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Char (isSpace)+import Data.Lens.Lazy (getL, setL, modL)+import Data.Map as Map (insertWith)+import Data.Maybe (fromMaybe, fromJust)+import Data.Monoid (mempty)+import Data.Set as Set (toList, fromList, insert, union, singleton)+import Data.Text (Text, unpack, pack, lines, words, break, strip, null)+import Data.Text.IO (readFile)+import Debian.Changes (ChangeLog(..), parseChangeLog)+import Debian.Control (Control'(unControl), Paragraph'(..), stripWS, parseControlFromFile, Field, Field'(..), ControlFunctions)+import Debian.Debianize.Atoms as Atoms+    (Atoms, rulesHead, compat, sourceFormat, watch, changelog, control, copyright,+     intermediateFiles, postInst, postRm, preInst, preRm, install, installDir, warning,+     logrotateStanza, installInit, link, packageDescription, compiler, maintainer, verbosity,+     compilerVersion, cabalFlagAssignments)+import Debian.Debianize.ControlFile (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..),+                                     VersionControlSpec(..), XField(..), newSourceDebDescription', newBinaryDebDescription)+import Debian.Debianize.Utility (getDirectoryContents', readFile', withCurrentDirectory)+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, license, maintainer))+import Distribution.PackageDescription.Configuration (finalizePackageDescription)+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..), Compiler(..))+import Distribution.Simple.Configure (configCompiler)+import Distribution.Simple.Program (defaultProgramConfiguration)+import Distribution.Simple.Utils (defaultPackageDesc, die, setupMessage)+import Distribution.System (Platform(..), buildOS, buildArch)+import Distribution.Verbosity (Verbosity, intToVerbosity)+import Prelude hiding (readFile, lines, words, break, null, log, sum)+import System.Cmd (system)+import System.Directory (doesFileExist)+import System.Exit (ExitCode(..))+import System.FilePath ((</>), takeExtension, dropExtension)+import System.Posix.Files (setFileCreationMask)+import System.IO.Error (catchIOError)+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)++inputDebianization :: FilePath -> IO Atoms+inputDebianization top =+    do (ctl, _) <- inputSourceDebDescription debian `catchIOError` (\ e -> error ("Failure parsing SourceDebDescription: " ++ show e))+       -- Different from snd of above?+       atoms <- inputAtomsFromDirectory debian mempty `catch` (\ (e :: SomeException) -> error ("Failure parsing atoms: " ++ show e))+       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)+       case paras of+         [] -> error "Missing source paragraph"+         [_] -> error "Missing binary paragraph"+         (hd : tl) -> return $ parseSourceDebDescription hd tl++parseSourceDebDescription :: Paragraph' String -> [Paragraph' String] -> (SourceDebDescription, [Field])+parseSourceDebDescription (Paragraph fields) binaryParagraphs =+    foldr readField (src, []) fields'+    where+      fields' = map stripField fields+      src = (newSourceDebDescription' findSource findMaint) {binaryPackages = bins}+      findSource = findMap "Source" SrcPkgName fields'+      findMaint = findMap "Maintainer" (either error id . parseMaintainer) fields'+      -- findStandards = findMap "Standards-Version" parseStandardsVersion fields'++      (bins, _extra) = unzip $ map parseBinaryDebDescription binaryParagraphs+      readField :: Field -> (SourceDebDescription, [Field]) -> (SourceDebDescription, [Field])+      -- Mandatory+      readField (Field ("Source", _)) x = x+      readField (Field ("Maintainer", _)) x = x+      -- readField (Field ("Standards-Version", _)) x = x+      -- Recommended+      readField (Field ("Standards-Version", value)) (desc, unrecognized) = (desc {standardsVersion = Just (parseStandardsVersion value)}, unrecognized)+      readField (Field ("Priority", value)) (desc, unrecognized) = (desc {priority = Just (readPriority value)}, unrecognized)+      readField (Field ("Section", value)) (desc, unrecognized) = (desc {section = Just (MainSection value)}, unrecognized)+      -- Optional+      readField (Field ("Homepage", value)) (desc, unrecognized) = (desc {homepage = Just (strip (pack value))}, unrecognized)+      readField (Field ("Uploaders", value)) (desc, unrecognized) = (desc {uploaders = either (const []) id (parseUploaders value)}, unrecognized)+      readField (Field ("DM-Upload-Allowed", value)) (desc, unrecognized) = (desc {dmUploadAllowed = yes value}, unrecognized)+      readField (Field ("Build-Depends", value)) (desc, unrecognized) = (desc {buildDepends = rels value}, unrecognized)+      readField (Field ("Build-Conflicts", value)) (desc, unrecognized) = (desc {buildConflicts = rels value}, unrecognized)+      readField (Field ("Build-Depends-Indep", value)) (desc, unrecognized) = (desc {buildDependsIndep = rels value}, unrecognized)+      readField (Field ("Build-Conflicts-Indep", value)) (desc, unrecognized) = (desc {buildConflictsIndep = rels value}, unrecognized)+      readField (Field ("Vcs-Browser", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBrowser (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Arch", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSArch (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Bzr", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBzr (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Cvs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSCvs (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Darcs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSDarcs (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Git", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSGit (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Hg", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSHg (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Mtn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSMtn (pack s)) (vcsFields desc)}, unrecognized)+      readField (Field ("Vcs-Svn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSSvn (pack s)) (vcsFields desc)}, unrecognized)+      readField field@(Field ('X' : fld, value)) (desc, unrecognized) =+          case span (`elem` "BCS") fld of+            (xs, '-' : more) -> (desc {xFields = insert (XField (fromList (map (read' . (: [])) xs)) (pack more) (pack value)) (xFields desc)}, unrecognized)+            _ -> (desc, field : unrecognized)+      readField field (desc, unrecognized) = (desc, field : unrecognized)++parseBinaryDebDescription :: Paragraph' String -> (BinaryDebDescription, [Field])+parseBinaryDebDescription (Paragraph fields) =+    foldr readField (bin, []) fields'+    where+      fields' = map stripField fields+      bin = newBinaryDebDescription findPackage findArchitecture+      findPackage = findMap "Package" BinPkgName fields'+      findArchitecture = findMap "Architecture" parsePackageArchitectures fields'+{-+(BinPkgName (fromJust (fieldValue "Package" bin)))+(read' (fromJust (fieldValue "Architecture" bin)))+, []+    foldr readField (newBinaryDebDescription (BinPkgName (fromJust (fieldValue "Package" bin))) (read' (fromJust (fieldValue "Architecture" bin))), []) (map stripField fields)+-}++      readField :: Field -> (BinaryDebDescription, [Field]) -> (BinaryDebDescription, [Field])+      readField (Field ("Package", value)) (desc, unrecognized) = (desc {package = BinPkgName value}, unrecognized)+      readField (Field ("Architecture", value)) (desc, unrecognized) = (desc {architecture = parsePackageArchitectures value}, unrecognized)+      readField (Field ("Section", value)) (desc, unrecognized) = (desc {binarySection = Just (readSection value)}, unrecognized)+      readField (Field ("Priority", value)) (desc, unrecognized) = (desc {binaryPriority = Just (readPriority value)}, unrecognized)+      readField (Field ("Essential", value)) (desc, unrecognized) = (desc {essential = yes value}, unrecognized)+      readField (Field ("Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {depends = rels value}}, unrecognized)+      readField (Field ("Recommends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {recommends = rels value}}, unrecognized)+      readField (Field ("Suggests", value)) (desc, unrecognized) = (desc {relations = (relations desc) {suggests = rels value}}, unrecognized)+      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 ("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)++-- | Look for a field and apply a function to its value+findMap :: String -> (String -> a) -> [Field] -> a+findMap field f fields =+    fromMaybe (error $ "Missing field: " ++ field) (foldr findMap' Nothing fields)+    where+      findMap' (Field (fld, val)) x = if fld == field then Just (f val) else x+      findMap' _ x = x++read' :: Read a => String -> a+read' s = trace ("read " ++ show s) (read s)++stripField :: ControlFunctions a => Field' a -> Field' a+stripField (Field (a, b)) = Field (a, stripWS b)+stripField x = x++rels :: String -> Relations+rels s =+    either (\ e -> error ("Relations field error: " ++ show e ++ "\n  " ++ s)) id (parseRelations s)++yes :: String -> Bool+yes "yes" = True+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++inputAtomsFromDirectory :: FilePath -> Atoms -> IO Atoms -- .install files, .init files, etc.+inputAtomsFromDirectory debian xs =+    findFiles xs >>= doFiles (debian </> "cabalInstall")+    where+      findFiles :: Atoms -> IO Atoms+      findFiles xs' =+          getDirectoryContents' debian >>=+          return . (++ ["source/format"]) >>=+          filterM (doesFileExist . (debian </>)) >>=+          foldM (\ xs'' name -> inputAtoms 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+             files <- mapM (readFile . (tmp </>)) paths+             foldM (\ xs'' (path, file) -> return $ modL intermediateFiles (Set.insert ("debian/cabalInstall" </> path, file)) xs'') xs' (zip paths files)++inputAtoms :: FilePath -> FilePath -> Atoms -> IO Atoms+inputAtoms _ path xs | elem path ["control"] = return xs+inputAtoms debian name@"source/format" xs = readFile (debian </> name) >>= \ text -> return $ (either (modL warning . Set.insert) (setL sourceFormat . Just) (readSourceFormat text)) xs+inputAtoms debian name@"watch" xs = readFile (debian </> name) >>= \ text -> return $ setL watch (Just text) xs+inputAtoms debian name@"rules" xs = readFile (debian </> name) >>= \ text -> return $ setL rulesHead (Just text) xs+inputAtoms debian name@"compat" xs = readFile (debian </> name) >>= \ text -> return $ setL compat (Just (read (unpack text))) xs+inputAtoms debian name@"copyright" xs = readFile (debian </> name) >>= \ text -> return $ setL copyright (Just (Right text)) xs+inputAtoms debian name@"changelog" xs =+    readFile (debian </> name) >>= return . parseChangeLog . unpack >>= \ log -> return $ setL changelog (Just log) xs+inputAtoms debian name xs =+    case (BinPkgName (dropExtension name), takeExtension name) of+      (p, ".install") ->   readFile (debian </> name) >>= \ text -> return $ foldr (readInstall p) xs (lines text)+      (p, ".dirs") ->      readFile (debian </> name) >>= \ text -> return $ foldr (readDir p) xs (lines text)+      (p, ".init") ->      readFile (debian </> name) >>= \ text -> return $ modL installInit (insertWith (error "inputAtoms") p text) xs+      (p, ".logrotate") -> readFile (debian </> name) >>= \ text -> return $ modL logrotateStanza (insertWith Set.union p (singleton text)) xs+      (p, ".links") ->     readFile (debian </> name) >>= \ text -> return $ foldr (readLink p) xs (lines text)+      (p, ".postinst") ->  readFile (debian </> name) >>= \ text -> return $ modL postInst (insertWith (error "inputAtoms") p text) xs+      (p, ".postrm") ->    readFile (debian </> name) >>= \ text -> return $ modL postRm (insertWith (error "inputAtoms") p text) xs+      (p, ".preinst") ->   readFile (debian </> name) >>= \ text -> return $ modL preInst (insertWith (error "inputAtoms") p text) xs+      (p, ".prerm") ->     readFile (debian </> name) >>= \ text -> return $ modL preRm (insertWith (error "inputAtoms") p text) xs+      (_, ".log") ->       return xs -- Generated by debhelper+      (_, ".debhelper") -> return xs -- Generated by debhelper+      (_, ".hs") ->        return xs -- Code that uses this library+      (_, ".setup") ->     return xs -- Compiled Setup.hs file+      (_, ".substvars") -> return xs -- Unsupported+      (_, "") ->           return xs -- File with no extension+      (_, x) | last x == '~' -> return xs -- backup file+      _ -> trace ("Ignored: " ++ debian </> name) (return xs)++readLink :: BinPkgName -> Text -> Atoms -> Atoms+readLink p line atoms =+    case words line of+      [a, b] -> modL link (insertWith Set.union p (singleton (unpack a, unpack b))) atoms+      [] -> atoms+      _ -> trace ("readLink: " ++ show line) atoms++readInstall :: BinPkgName -> Text -> Atoms -> Atoms+readInstall p line atoms =+    case break isSpace line of+      (_, b) | null b -> error $ "readInstall: syntax error in .install file for " ++ show p ++ ": " ++ show line+      (a, b) -> modL install (insertWith union p (singleton (unpack (strip a), unpack (strip b)))) atoms++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 =+    withCurrentDirectory top $ do+      descPath <- defaultPackageDesc vb+      genPkgDesc <- readPackageDescription vb descPath+      (compiler', _) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration vb+      let compiler'' = case getL compilerVersion atoms of+                         (Just ver) -> compiler' {compilerId = CompilerId GHC ver}+                         _ -> compiler'+      case finalizePackageDescription (toList (getL cabalFlagAssignments atoms)) (const True) (Platform buildArch buildOS) (compilerId compiler'') [] genPkgDesc of+        Left e -> error $ "Failed to load cabal package description: " ++ show e+        Right (pkgDesc, _) -> do+          liftIO $ bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc+          return $ setL compiler (Just compiler'') $+                   setL packageDescription (Just pkgDesc) $ atoms+    where+      vb = intToVerbosity' (getL verbosity atoms)++-- | Run the package's configuration script.+autoreconf :: Verbosity -> PackageDescription -> IO ()+autoreconf verbose pkgDesc = do+    ac <- doesFileExist "configure.ac"+    when ac $ do+        c <- doesFileExist "configure"+        when (not c) $ do+            setupMessage verbose "Running autoreconf" (packageId pkgDesc)+            ret <- system "autoreconf"+            case ret of+              ExitSuccess -> return ()+              ExitFailure n -> die ("autoreconf failed with status " ++ show n)++-- | Try to read the license file specified in the cabal package,+-- otherwise return a text representation of the License field.+inputCopyright :: PackageDescription -> IO Text+inputCopyright pkgDesc = readFile' (licenseFile pkgDesc) `catchIOError` handle+    where handle _e =+              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"++-- | Try to compute the debian maintainer from the maintainer field of the+-- cabal package, or from the value returned by getDebianMaintainer.+inputMaintainer :: Atoms -> IO (Maybe NameAddr)+inputMaintainer atoms =+    debianPackageMaintainer >>= maybe cabalPackageMaintainer (return . Just) >>=+                                maybe getDebianMaintainer (return . Just) >>=+                                maybe lastResortMaintainer (return . Just)+    where+      debianPackageMaintainer :: IO (Maybe NameAddr)+      debianPackageMaintainer = return (getL Atoms.maintainer atoms)+      cabalPackageMaintainer :: IO (Maybe NameAddr)+      cabalPackageMaintainer = return $ case fmap Cabal.maintainer (getL packageDescription atoms) of+                                          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)))
+ src/Debian/Debianize/Interspersed.hs view
@@ -0,0 +1,61 @@+-- | A class used while converting Cabal dependencies into Debian+-- dependencies.++{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall -Werror #-}+module Debian.Debianize.Interspersed+    ( Interspersed(..)+    ) where++import Debug.Trace++-- | A class of Bs insterspersed with Cs.  It is used when converting+-- the cabal dependencies to debian, where the "around" type is the+-- binary package name and the "between" type is the version number.+-- +-- Minimum implementation is a method to return the leftmost B, and+-- another to return the following (C,B) pairs.  Its unfortunate to+-- require lists in the implementation, a fold function would be+-- better (though I find implementing such folds to be a pain in the+-- you-know-what.)+-- +-- The class provides implementations of three folds, each of which+-- exposes slightly different views of the data.+class Interspersed t around between | t -> around, t -> between where+    leftmost :: t -> around+    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)++    -- 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+    -- ends.+    foldInverted :: (Maybe between -> around -> Maybe between -> r -> r) -> r -> t -> r+    foldInverted f r0 x =+        (\ (bn, an, r) -> f bn an Nothing r) $+           foldl g (Nothing, leftmost x, r0) (pairs x)+        where+          g (b1, a1, r) (b2, a2) = (Just b2, a2, f b1 a1 (Just b2) r)++    foldArounds :: (around -> around -> r -> r) -> r -> t -> r+    foldArounds f r0 x = snd $ foldl (\ (a1, r) (_, a2) -> (a2, f a1 a2 r)) (leftmost x, r0) (pairs x)++    foldBetweens :: (between -> r -> r) -> r -> t -> r+    foldBetweens f r0 x = foldl (\ r (b, _) -> (f b r)) r0 (pairs x)++-- | An example+data Splits = Splits Double [(String, Double)] deriving Show++instance Interspersed Splits Double String where+    leftmost (Splits x _) = x+    pairs (Splits _ x) = x++_splits :: Splits+_splits = Splits 1.0 [("between 1 and 2", 2.0), ("between 2 and 3", 3.0)]++_test1 :: ()+_test1 = foldTriples (\ l s r () -> trace ("l=" ++ show l ++ " s=" ++ show s ++ " r=" ++ show r) ()) () _splits++_test2 :: ()+_test2 = foldInverted (\ sl f sr () -> trace ("sl=" ++ show sl ++ " f=" ++ show f ++ " sr=" ++ show sr) ()) () _splits
+ src/Debian/Debianize/Options.hs view
@@ -0,0 +1,135 @@+module Debian.Debianize.Options+    ( compileArgs+    , options+    ) where++import Data.Char (toLower, isDigit, ord)+import Data.Lens.Lazy (setL, modL)+import Data.Map as Map (insertWith)+import Data.Set as Set (fromList, insert, union, singleton)+import Data.Version (parseVersion)+import Debian.Debianize.Atoms -- (Atoms, depends, conflicts)+import Debian.Debianize.Goodies (doExecutable)+import Debian.Debianize.Types (InstallFile(..), DebAction(..))+import Debian.Orphans ()+import Debian.Policy (SourceFormat(Quilt3), parseMaintainer)+import Debian.Relation (BinPkgName(..), SrcPkgName(..), Relation(..))+import Debian.Version (parseDebianVersion)+import Distribution.PackageDescription (FlagName(..))+import Distribution.Package (PackageName(..))+import Prelude hiding (readFile, lines, null, log, sum)+import System.Console.GetOpt (ArgDescr(..), OptDescr(..), ArgOrder(RequireOrder), getOpt')+import System.FilePath ((</>), splitFileName)+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Regex.TDFA ((=~))++compileArgs :: [String] -> Atoms -> Atoms+compileArgs args atoms =+    case getOpt' RequireOrder options args of+      (os, [], [], []) -> foldl (flip ($)) atoms os+      (_, non, unk, errs) -> error ("Errors: " ++ show errs +++                                    ", Unrecognized: " ++ show unk +++                                    ", Non-Options: " ++ show non)++-- | Options that modify other atoms.+options :: [OptDescr (Atoms -> Atoms)]+options =+    [ Option "v" ["verbose"] (ReqArg (\ s atoms -> setL verbosity (read s) atoms) "n")+             "Change build verbosity",+      Option "n" ["dry-run", "compare"] (NoArg (\ atoms -> setL dryRun True atoms))+             "Just compare the existing debianization to the one we would generate.",+      Option "h?" ["help"] (NoArg (\ atoms -> setL debAction Usage atoms))+             "Show this help text",+      Option "" ["debianize"] (NoArg (\ atoms -> setL debAction Debianize atoms))+             "Generate a new debianization, replacing any existing one.  One of --debianize or --substvar is required.",+      Option "" ["substvar"] (ReqArg (\ name atoms -> setL debAction (SubstVar (read name)) atoms) "Doc, Prof, or Dev")+             (unlines ["Write out the list of dependencies required for the dev, prof or doc package depending",+                       "on the argument.  This value can be added to the appropriate substvars file."]),+      Option "" ["executable"] (ReqArg (\ path x -> executableOption path (\ bin e -> doExecutable bin e x)) "SOURCEPATH or SOURCEPATH:DESTDIR")+             "Create individual eponymous executable packages for these executables.  Other executables and data files are gathered into a single utils package.",+      Option "" ["ghc-version"] (ReqArg (\ ver x -> setL compilerVersion (Just (last (map fst (readP_to_S parseVersion ver)))) x) "VERSION")+             "Version of GHC in build environment",+      Option "" ["disable-haddock"] (NoArg (setL noDocumentationLibrary True))+             "Don't generate API documentation.  Use this if build is crashing due to a haddock error.",+      Option "" ["missing-dependency"] (ReqArg (\ name atoms -> modL missingDependencies (insert (BinPkgName name)) atoms) "DEB")+             "Mark a package missing, do not add it to any dependency lists in the debianization.",+      Option "" ["source-package-name"] (ReqArg (\ name x -> setL sourcePackageName (Just (SrcPkgName name)) x) "NAME")+             "Use this name for the debian source package.  Default is haskell-<cabalname>, where the cabal package name is downcased.",+      Option "" ["disable-library-profiling"] (NoArg (setL noProfilingLibrary True))+             "Don't generate profiling libraries",+      Option "f" ["flags"] (ReqArg (\ fs atoms -> modL cabalFlagAssignments (union (fromList (flagList fs))) atoms) "FLAGS")+             "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")+             "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")+             "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")+             "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 "" ["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")+             "Specify a mapping from the name appearing in the Extra-Library field of the cabal file to a debian binary package name, e.g. --dep-map cryptopp=libcrypto-dev",+      Option "" ["deb-version"] (ReqArg (\ version atoms -> setL debVersion (Just (parseDebianVersion version)) atoms) "VERSION")+             "Specify the version number for the debian package.  This will pin the version and should be considered dangerous.",+      Option "" ["revision"] (ReqArg (setL revision . Just) "REVISION")+             "Add this string to the cabal version to get the debian version number.  By default this is '-1~hackage1'.  Debian policy says this must either be empty (--revision '') or begin with a dash.",+      Option "" ["epoch-map"] (ReqArg (\ pair atoms -> case break (== '=') pair of+                                                         (_, (_ : ['0'])) -> atoms+                                                         (cab, (_ : [d])) | isDigit d -> modL epochMap (Map.insertWith (flip const) (PackageName cab) (ord d - ord '0')) atoms+                                                         _ -> error "usage: --epoch-map CABALNAME=DIGIT") "CABALNAME=DIGIT")+             "Specify a mapping from the cabal package name to a digit to use as the debian package epoch number, e.g. --epoch-map HTTP=1",+      Option "" ["exec-map"] (ReqArg (\ s atoms -> case break (== '=') s of+                                                     (cab, (_ : deb)) -> modL execMap (Map.insertWith (flip const) cab (b deb)) atoms+                                                     _ -> error "usage: --exec-map CABALNAME=DEBNAME") "EXECNAME=DEBIANNAME")+             "Specify a mapping from the name appearing in the Build-Tool field of the cabal file to a debian binary package name, e.g. --exec-map trhsx=haskell-hsx-utils",+      Option "" ["omit-lt-deps"] (NoArg (setL omitLTDeps True))+             "Don't generate the << dependency when we see a cabal equals dependency.",+      Option "" ["quilt"] (NoArg (setL sourceFormat (Just Quilt3)))+             "The package has an upstream tarball, write '3.0 (quilt)' into source/format.",+      Option "" ["builddir"] (ReqArg (\ s atoms -> setL buildDir (Just (s </> "build")) atoms) "PATH")+             "Subdirectory where cabal does its build, dist/build by default, dist-ghc when run by haskell-devscripts.  The build subdirectory is added to match the behavior of the --builddir option in the Setup script."+    ]++anyrel :: BinPkgName -> Relation+anyrel x = Rel x Nothing Nothing++-- | Process a --executable command line argument+executableOption :: String -> (BinPkgName -> InstallFile -> a) -> a+executableOption arg f =+    case span (/= ':') arg of+      (sp, md) ->+          let (sd, name) = splitFileName sp in+          f (BinPkgName name)+            (InstallFile { execName = name+                         , destName = name+                         , sourceDir = case sd of "./" -> Nothing; _ -> Just sd+                         , destDir = case md of (':' : dd) -> Just dd; _ -> Nothing })++parseDeps :: String -> [(BinPkgName, Relation)]+parseDeps arg =+    map pair (split arg)+    where+      split s =+          case s =~ "^[ \t,]*([^,]+)[ \t,]*" :: (String, String, String, [String]) of+            (_, _, tl, [hd]) -> hd : split tl+            (_, _, "", _) -> []+            _ -> error $ "Invalid dependency: " ++ show s+      pair s =+          case s =~ "^[ \t:]*([^ \t:]+)[ \t]*:[ \t]*(.+)[ \t]*" :: (String, String, String, [String]) of+            (_, _, _, [x, y]) -> (b x, anyrel (b y))+            _ -> error $ "Invalid dependency: " ++ show s++-- Lifted from Distribution.Simple.Setup, since it's not exported.+flagList :: String -> [(FlagName, Bool)]+flagList = map tagWithValue . words+  where tagWithValue ('-':name) = (FlagName (map toLower name), False)+        tagWithValue name       = (FlagName (map toLower name), True)++b :: String -> BinPkgName+b = BinPkgName
+ src/Debian/Debianize/SubstVars.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections, TypeSynonymInstances #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}++-- | Support for generating Debianization from Cabal data.++module Debian.Debianize.SubstVars+    ( substvars+    ) where++import Control.Exception (SomeException, try)+import Control.Monad (foldM)+import Control.Monad.Reader (ReaderT(runReaderT))+import Control.Monad.Trans (lift)+import Data.Lens.Lazy (getL, modL)+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.Text (pack)+import Debian.Control+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.Utility (buildDebVersionMap, DebMap, showDeps, dpkgFileMap, cond, debOfFile, (!), diffFile, replaceFile)+import qualified Debian.Relation as D+import Distribution.Package (Dependency(..), PackageName(PackageName))+import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..))+import Distribution.Simple.Utils (die)+import Distribution.Text (display)+import System.Directory (doesDirectoryExist, getDirectoryContents)+import System.FilePath ((</>))+import Text.PrettyPrint.ANSI.Leijen (pretty)++-- | Expand the contents of the .substvars file for a library package.+-- Each cabal package corresponds to a directory <name>-<version>,+-- either in /usr/lib or in /usr/lib/haskell-packages/ghc/lib.  In+-- that directory is a compiler subdirectory such as ghc-6.8.2.  In+-- the ghc subdirectory is one or two library files of the form+-- libHS<name>-<version>.a and libHS<name>-<version>_p.a.  We can+-- determine the debian package names by running dpkg -S on these+-- names, or examining the /var/lib/dpkg/info/\*.list files.  From+-- these we can determine the source package name, and from that the+-- documentation package name.+substvars :: Atoms+          -> DebType  -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc+          -> IO ()+substvars atoms debType =+    do atoms' <- inputCabalization "." atoms+       debVersions <- buildDebVersionMap+       atoms'' <- libPaths (fromMaybe (error "substvars") $ getL compiler atoms') debVersions atoms'+       control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control"+       substvars' atoms'' debType control++substvars' :: Atoms -> DebType -> Control' String -> IO ()+substvars' atoms debType control =+    case (missingBuildDeps, path) of+      -- There should already be a .substvars file produced by dh_haskell_prep,+      -- keep the relations listed there.  They will contain something like this:+      -- libghc-cabal-debian-prof.substvars:+      --    haskell:Depends=ghc-prof (<< 6.8.2-999), ghc-prof (>= 6.8.2), libghc-cabal-debian-dev (= 0.4)+      -- libghc-cabal-debian-dev.substvars:+      --    haskell:Depends=ghc (<< 6.8.2-999), ghc (>= 6.8.2)+      -- haskell-cabal-debian-doc.substvars:+      --    haskell:Depends=ghc-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999)+      ([], Just path') ->+          readFile path' >>= \ old ->+          let new = addDeps old in+          diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path'))+                                              (\ diff -> if getL dryRun atoms then putStr diff else replaceFile path' new)+      ([], Nothing) -> return ()+      (missing, _) ->+          die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n  " ++ intercalate "\n  " (map (show . pretty . fst) missing) +++               "\nIf this is an obsolete package you may need to withdraw the old versions from the\n" +++               "upstream repository, and uninstall and purge it from your local system.")+    where+      addDeps old =+          case partition (isPrefixOf "haskell:Depends=") (lines old) of+            ([], other) -> unlines (("haskell:Depends=" ++ showDeps (filterMissing atoms deps)) : other)+            (hdeps, more) ->+                case deps of+                  [] -> unlines (hdeps ++ more)+                  _ -> unlines (map (++ (", " ++ showDeps (filterMissing atoms deps))) hdeps ++ more)+      path = fmap (\ (D.BinPkgName x) -> "debian/" ++ x ++ ".substvars") name+      name = debNameFromType control debType+      deps = debDeps debType atoms control+      -- We must have build dependencies on the profiling and documentation packages+      -- of all the cabal packages.+      missingBuildDeps =+          let requiredDebs =+                  concat (map (\ (Dependency name _) ->+                               case Map.lookup name (getL packageInfo atoms) of+                                 Just info ->+                                     let prof = maybe (devDeb info) Just (profDeb info) in+                                     let doc = docDeb info in+                                     catMaybes [prof, doc]+                                 Nothing -> []) (cabalDependencies atoms)) in+          filter (not . (`elem` buildDepNames) . fst) requiredDebs+      buildDepNames :: [D.BinPkgName]+      buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps)+      buildDeps :: D.Relations+      buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi)+      --sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control)))+      bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control+      bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control++libPaths :: Compiler -> DebMap -> Atoms -> IO Atoms+libPaths compiler debVersions atoms+    | compilerFlavor compiler == GHC =+        do a <- getDirPaths "/usr/lib"+           b <- getDirPaths "/usr/lib/haskell-packages/ghc/lib"+           -- Build a map from names of installed debs to version numbers+           dpkgFileMap >>= runReaderT (foldM (packageInfo' compiler debVersions) atoms (a ++ b))+    | True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler)+    where+      getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id++packageInfo' :: Compiler ->  DebMap -> Atoms -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO Atoms+packageInfo' compiler debVersions atoms (d, f) =+    case parseNameVersion f of+      Nothing -> return atoms+      Just (p, v) -> lift (doesDirectoryExist (d </> f </> cdir)) >>= cond (return atoms) (info (p, v))+    where+      parseNameVersion s =+          case (break (== '-') (reverse s)) of+            (_a, "") -> Nothing+            (a, b) -> Just (reverse (tail b), reverse a)+      cdir = display (compilerId compiler)+      info (p, v) =+          do dev <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ ".a$")+             prof <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ "_p.a$")+             doc <- debOfFile ("/" ++ p ++ ".haddock$")+             return $ modL packageInfo (Map.insert+                                           (PackageName p)+                                           (PackageInfo { cabalName = PackageName p+                                                        , devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev+                                                        , profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof+                                                        , docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) atoms
+ src/Debian/Debianize/Tests.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Debian.Debianize.Tests+    ( tests+    ) where++import Data.Algorithm.Diff.Context (contextDiff)+import Data.Algorithm.Diff.Pretty (prettyDiff)+import Data.Function (on)+import Data.Lens.Lazy (setL, getL, modL)+import Data.List (sortBy)+import Data.Map as Map (differenceWithKey, intersectionWithKey)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Monoid (mconcat, (<>), mempty)+import Data.Set as Set (fromList, union, insert, singleton)+import qualified Data.Text as T+import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry)+import Debian.Debianize.Debianize (debianization)+import Debian.Debianize.Atoms as Atoms+    (Atoms, rulesHead, compat, sourceFormat, changelog, sourcePackageName, control, missingDependencies, revision,+     binaryArchitectures, copyright, debVersion, execMap, buildDeps, buildDepsIndep, utilsPackageName, description,+     depends, conflicts, install, installData)+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.Input (inputChangeLog, inputDebianization, inputCabalization)+import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..))+import Debian.Policy (databaseDirectory, StandardsVersion(StandardsVersion), getDebhelperCompatLevel,+                      getDebianStandardsVersion, PackagePriority(Extra), PackageArchitectures(All),+                      SourceFormat(Native3), Section(..), parseMaintainer)+import Debian.Relation (Relation(..), VersionReq(..), SrcPkgName(..), BinPkgName(..))+import Debian.Release (ReleaseName(ReleaseName, relName))+import Debian.Version (buildDebianVersion, parseDebianVersion)+import Distribution.License (License(BSD3))+import Prelude hiding (log)+import System.FilePath ((</>))+import Test.HUnit+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..))+import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty, text)++-- | 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.+newDebianization :: ChangeLog -> Int -> StandardsVersion -> Atoms+newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry"+newDebianization (log@(ChangeLog (entry : _))) level standards =+    setL changelog (Just log) $+    setL compat (Just level) $+    modL control (\ x -> x { source = Just (SrcPkgName (logPackage entry))+                           , maintainer = (either error Just (parseMaintainer (logWho entry)))+                           , standardsVersion = Just standards }) $+    defaultAtoms+newDebianization _ _ _ = error "Invalid changelog"++newDebianization' :: Int -> StandardsVersion -> Atoms+newDebianization' level standards =+    setL compat (Just level) $+    modL control (\ x -> x { standardsVersion = Just standards }) $+    defaultAtoms++tests :: Test+tests = TestLabel "Debianization Tests" (TestList [test1, test2, test3, test4, test5, test6, test7, test8, test9])++test1 :: Test+test1 =+    TestLabel "test1" $+    TestCase (do level <- getDebhelperCompatLevel+                 standards <- getDebianStandardsVersion+                 let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $+                           newDebianization (ChangeLog [testEntry]) level standards+                 assertEqual "test1" [] (diffDebianizations testDeb1 deb))+    where+      testDeb1 :: Atoms+      testDeb1 =+          setL rulesHead (Just . T.unlines $+                          [ "#!/usr/bin/make -f"+                          , ""+                          , "include /usr/share/cdbs/1/rules/debhelper.mk"+                          , "include /usr/share/cdbs/1/class/hlibrary.mk" ]) $+          setL compat (Just 9) $ -- This will change as new version of debhelper are released+          setL copyright (Just (Left BSD3)) $+          modL control+              (\ y -> y { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"})+                        , maintainer = Just (NameAddr (Just "David Fox") "dsf@seereason.com")+                        , standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)) -- This will change as new versions of debian-policy are released+                        , buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing],+                                                  [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing],+                                                  [Rel (BinPkgName "cdbs") Nothing Nothing],+                                                  [Rel (BinPkgName "ghc") Nothing Nothing],+                                                  [Rel (BinPkgName "ghc-prof") Nothing Nothing]]+                        , buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]]+                        }) $+          (newDebianization log 9 (StandardsVersion 3 9 3 (Just 1)))+      log = ChangeLog [Entry { logPackage = "haskell-cabal-debian"+                             , logVersion = buildDebianVersion Nothing "2.6.2" Nothing+                             , logDists = [ReleaseName {relName = "unstable"}]+                             , logUrgency = "low"+                             , logComments = "  * Fix a bug constructing the destination pathnames that was dropping\n    files that were supposed to be installed into packages.\n"+                             , logWho = "David Fox <dsf@seereason.com>"+                             , logDate = "Thu, 20 Dec 2012 06:49:25 -0800" }]++test2 :: Test+test2 =+    TestLabel "test2" $+    TestCase (do level <- getDebhelperCompatLevel+                 standards <- getDebianStandardsVersion+                 let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ newDebianization (ChangeLog [testEntry]) level standards+                 assertEqual "test2" [] (diffDebianizations expect deb))+    where+      expect =+          setL rulesHead (Just . T.unlines $+                          ["#!/usr/bin/make -f",+                           "",+                           "include /usr/share/cdbs/1/rules/debhelper.mk",+                           "include /usr/share/cdbs/1/class/hlibrary.mk"]) $+          setL compat (Just 9) $+          setL copyright (Just (Left BSD3)) $+          modL control+              (\ y -> y+                { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}),+                  maintainer = Just (NameAddr {nameAddr_name = Just "David Fox", nameAddr_addr = "dsf@seereason.com"}),+                  standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)),+                  buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing],+                                  [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing],+                                  [Rel (BinPkgName "cdbs") Nothing Nothing],+                                  [Rel (BinPkgName "ghc") Nothing Nothing],+                                  [Rel (BinPkgName "ghc-prof") Nothing Nothing]],+                  buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]]+                }) $+          (newDebianization log 9 (StandardsVersion 3 9 3 (Just 1)))+      log = ChangeLog [Entry {logPackage = "haskell-cabal-debian",+                              logVersion = Debian.Version.parseDebianVersion ("2.6.2" :: String),+                              logDists = [ReleaseName {relName = "unstable"}],+                              logUrgency = "low",+                              logComments = unlines ["  * Fix a bug constructing the destination pathnames that was dropping",+                                                     "    files that were supposed to be installed into packages."],+                              logWho = "David Fox <dsf@seereason.com>",+                              logDate = "Thu, 20 Dec 2012 06:49:25 -0800"}]++test3 :: Test+test3 =+    TestLabel "test3" $+    TestCase (do deb <- inputDebianization "test-data/haskell-devscripts"+                 assertEqual "test3" [] (diffDebianizations testDeb2 deb))+    where+      testDeb2 :: Atoms+      testDeb2 =+          setL sourceFormat (Just Native3) $+          setL rulesHead (Just "#!/usr/bin/make -f\n# -*- makefile -*-\n\n# Uncomment this to turn on verbose mode.\n#export DH_VERBOSE=1\n\nDEB_VERSION := $(shell dpkg-parsechangelog | egrep '^Version:' | cut -f 2 -d ' ')\n\nmanpages = $(shell cat debian/manpages)\n\n%.1: %.pod\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n%.1: %\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n.PHONY: build\nbuild: $(manpages)\n\ninstall-stamp:\n\tdh install\n\n.PHONY: install\ninstall: install-stamp\n\nbinary-indep-stamp: install-stamp\n\tdh binary-indep\n\ttouch $@\n\n.PHONY: binary-indep\nbinary-indep: binary-indep-stamp\n\n.PHONY: binary-arch\nbinary-arch: install-stamp\n\n.PHONY: binary\nbinary: binary-indep-stamp\n\n.PHONY: clean\nclean:\n\tdh clean\n\trm -f $(manpages)\n\n\n") $+          setL compat (Just 7) $+          setL copyright (Just (Right "This package was debianized by John Goerzen <jgoerzen@complete.org> on\nWed,  6 Oct 2004 09:46:14 -0500.\n\nCopyright information removed from this test data.\n\n")) $+          modL control+              (\ y -> y+                { source = Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"})+                , maintainer = Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"})+                , uploaders = [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}]+                , priority = Just Extra+                , section = Just (MainSection "haskell")+                , buildDepends = (buildDepends y) ++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]]+                , buildDependsIndep = (buildDependsIndep y) ++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]]+                , standardsVersion = Just (StandardsVersion 3 9 4 Nothing)+                , vcsFields = Set.union (vcsFields y) (Set.fromList [ VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts"+                                                                    , VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"])+                , binaryPackages = [BinaryDebDescription { package = BinPkgName {unBinPkgName = "haskell-devscripts"}+                                                         , architecture = All+                                                         , binarySection = Nothing+                                                         , binaryPriority = Nothing+                                                         , essential = False+                                                         , Deb.description =+                                                             (T.intercalate "\n"+                                                                          ["Tools to help Debian developers build Haskell packages",+                                                                           " This package provides a collection of scripts to help build Haskell",+                                                                           " packages for Debian.  Unlike haskell-utils, this package is not",+                                                                           " expected to be installed on the machines of end users.",+                                                                           " .",+                                                                           " This package is designed to support Cabalized Haskell libraries.  It",+                                                                           " is designed to build a library for each supported Debian compiler or",+                                                                           " interpreter, generate appropriate postinst/prerm files for each one,",+                                                                           " generate appropriate substvars entries for each one, and install the",+                                                                           " package in the Debian temporary area as part of the build process."])+                                                         , relations =+                                                             PackageRelations+                                                             { Deb.depends =+                                                                   [ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "ghc"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.6" :: String)))) Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "cdbs"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "${misc:Depends}"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "html-xml-utils"}) Nothing Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "hscolour"}) (Just (GRE (Debian.Version.parseDebianVersion ("1.8" :: String)))) Nothing]+                                                                   , [Rel (BinPkgName {unBinPkgName = "ghc-haddock"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.4" :: String)))) Nothing] ]+                                                             , recommends = []+                                                             , suggests = []+                                                             , preDepends = []+                                                             , breaks = []+                                                             , Deb.conflicts = []+                                                             , provides = []+                                                             , replaces = []+                                                             , builtUsing = [] }}]}) $+          (newDebianization log 7 (StandardsVersion 3 9 4 Nothing))+      log = ChangeLog [Entry { logPackage = "haskell-devscripts"+                             , logVersion = Debian.Version.parseDebianVersion ("0.8.13" :: String)+                             , logDists = [ReleaseName {relName = "experimental"}]+                             , logUrgency = "low"+                             , logComments = "  [ Joachim Breitner ]\n  * Improve parsing of \"Setup register\" output, patch by David Fox\n  * Enable creation of hoogle files, thanks to Kiwamu Okabe for the\n    suggestion. \n\n  [ Kiwamu Okabe ]\n  * Need --html option to fix bug that --hoogle option don't output html file.\n  * Support to create /usr/lib/ghc-doc/hoogle/*.txt for hoogle package.\n\n  [ Joachim Breitner ]\n  * Symlink hoogle\8217s txt files to /usr/lib/ghc-doc/hoogle/\n  * Bump ghc dependency to 7.6 \n  * Bump standards version\n"+                             , logWho = "Joachim Breitner <nomeata@debian.org>"+                             , logDate = "Mon, 08 Oct 2012 21:14:50 +0200" },+                       Entry { logPackage = "haskell-devscripts"+                             , logVersion = Debian.Version.parseDebianVersion ("0.8.12" :: String)+                             , logDists = [ReleaseName {relName = "unstable"}]+                             , logUrgency = "low"+                             , logComments = "  * Depend on ghc >= 7.4, adjusting to its haddock --interface-version\n    behaviour.\n"+                             , logWho = "Joachim Breitner <nomeata@debian.org>"+                             , logDate = "Sat, 04 Feb 2012 10:50:33 +0100"}]++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))+                 assertEqual "test4" [] (diffDebianizations old (copyFirstLogEntry old new)))+    where+      -- 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"]+      -- Insert a line just above the debhelper.mk include+      fixRules deb =+          modL rulesHead (\ mt -> (Just . f) (fromMaybe (getRulesHead deb) mt)) deb+          where+            f t = T.unlines $ concat $+                  map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk"+                                 then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text]+                                 else [line] :: [T.Text]) (T.lines t)+{-+          mapAtoms f deb+          where+            f :: DebAtomKey -> DebAtom -> Set (DebAtomKey, DebAtom)+            f Source (DebRulesHead t) =+                singleton (Source, DebRulesHead (T.unlines $ concat $+                                                 map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk"+                                                                then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text]+                                                                else [line] :: [T.Text]) (T.lines t)))+            f k a = singleton (k, a)+-}+      tight deb = foldr (tightDependencyFixup+                         -- For each pair (A, B) make sure that this package requires the+                         -- same exact version of package B as the version of A currently+                         -- installed during the build.+                         [(BinPkgName "libghc-clckwrks-theme-clckwrks-dev", BinPkgName "haskell-clckwrks-theme-clckwrks-utils"),+                          (BinPkgName "libghc-clckwrks-plugin-media-dev", BinPkgName "haskell-clckwrks-plugin-media-utils"),+                          (BinPkgName "libghc-clckwrks-plugin-bugs-dev", BinPkgName "haskell-clckwrks-plugin-bugs-utils"),+                          (BinPkgName "libghc-clckwrks-dev", BinPkgName "haskell-clckwrks-utils")]) deb serverNames++      theSite :: BinPkgName -> Site+      theSite deb =+          Site { domain = hostname'+               , serverAdmin = "logic@seereason.com"+               , server = theServer deb }+      theServer :: BinPkgName -> Server+      theServer deb =+          Server { hostname =+                       case deb of+                         BinPkgName "clckwrks-dot-com-production" -> hostname'+                         _ -> hostname'+                 , port = portNum deb+                 , headerMessage = "Generated by clckwrks-dot-com/Setup.hs"+                 , retry = "60"+                 , serverFlags =+                     [ "--http-port", show (portNum deb)+                     , "--hide-port"+                     , "--hostname", hostname'+                     , "--top", databaseDirectory deb+                     , "--enable-analytics"+                     , "--jquery-path", "/usr/share/javascript/jquery/"+                     , "--jqueryui-path", "/usr/share/javascript/jquery-ui/"+                     , "--jstree-path", jstreePath+                     , "--json2-path",json2Path+                     ]+                 , installFile =+                     InstallFile { execName   = "clckwrks-dot-com-server"+                                 , destName   = show (pretty deb)+                                 , sourceDir  = Nothing+                                 , destDir    = Nothing }+                 }+      hostname' = "clckwrks.com"+      portNum :: BinPkgName -> Int+      portNum (BinPkgName deb) =+          case deb of+            "clckwrks-dot-com-production"  -> 9029+            "clckwrks-dot-com-staging"     -> 9038+            "clckwrks-dot-com-development" -> 9039+            _ -> error $ "Unexpected package name: " ++ deb+      jstreePath = "/usr/share/clckwrks-0.13.2/jstree"+      json2Path = "/usr/share/clckwrks-0.13.2/json2"++anyrel :: BinPkgName -> Relation+anyrel b = Rel b Nothing Nothing++test5 :: Test+test5 =+    TestLabel "test5" $+    TestCase (do old <- inputDebianization "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")) $+                           modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-data")+                                                    (T.intercalate "\n" [ "creativeprompts.com data files"+                                                               , "  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." ])) $+                           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." ])) $+                           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) $+                           (newDebianization' level standards))+                 assertEqual "test5" [] (diffDebianizations old (copyFirstLogEntry old new)))+    where+      theSite :: BinPkgName -> Site+      theSite deb =+          Site { domain = hostname'+               , serverAdmin = "logic@seereason.com"+               , server = theServer deb }+      theServer :: BinPkgName -> Server+      theServer deb =+          Server { hostname =+                       case deb of+                         BinPkgName "clckwrks-dot-com-production" -> hostname'+                         _ -> hostname'+                 , port = portNum deb+                 , headerMessage = "Generated by creativeprompts-dot-com/debian/Debianize.hs"+                 , retry = "60"+                 , serverFlags =+                     [ "--http-port", show (portNum deb)+                     , "--hide-port"+                     , "--hostname", hostname'+                     , "--top", databaseDirectory deb+                     , "--enable-analytics"+                     , "--jquery-path", "/usr/share/javascript/jquery/"+                     , "--jqueryui-path", "/usr/share/javascript/jquery-ui/"+                     , "--jstree-path", jstreePath+                     , "--json2-path",json2Path+                     ]+                 , installFile =+                     InstallFile { execName   = "creativeprompts-server"+                                 , destName   = show (pretty deb)+                                 , sourceDir  = Nothing+                                 , destDir    = Nothing }+                 }+      hostname' = "creativeprompts.com"+      portNum :: BinPkgName -> Int+      portNum (BinPkgName deb) =+          case deb of+            "creativeprompts-production"  -> 9022+            "creativeprompts-staging"     -> 9033+            "creativeprompts-development" -> 9034+            _ -> error $ "Unexpected package name: " ++ deb+      jstreePath = "/usr/share/clckwrks-0.13.2/jstree"+      json2Path = "/usr/share/clckwrks-0.13.2/json2"+++copyFirstLogEntry :: Atoms -> Atoms -> Atoms+copyFirstLogEntry deb1 deb2 =+    modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2+    where+      ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1)+      ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2)++copyChangelog :: Atoms -> Atoms -> Atoms+copyChangelog deb1 deb2 = modL changelog (const (getL changelog deb1)) deb2++test6 :: Test+test6 =+    TestLabel "test6" $+    TestCase ( do old <- inputDebianization "test-data/artvaluereport2/output"+                  new <- debianization "test-data/artvaluereport2/input"+                            (modL control (\ y -> y {homepage = Just "http://appraisalreportonline.com"}) $+                             setL sourcePackageName (Just (SrcPkgName "haskell-artvaluereport2")) $+                             setL utilsPackageName (Just (BinPkgName "artvaluereport2-server")) $+                             modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-development") All) $+                             modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-production") All) $+                             modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-staging") All) $+                             modL buildDepsIndep (Set.insert (BinPkgName "libjs-jcrop")) $+                             modL buildDepsIndep (Set.insert (BinPkgName "libjs-jquery")) $+                             modL buildDepsIndep (Set.insert (BinPkgName "libjs-jquery-u")) $++                             modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-development") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $+                             modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-production") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $+                             modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-production") (singleton (anyrel (BinPkgName "apache2")))) $+                             modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-staging") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $+                             -- This should go into the "real" data directory.  And maybe a different icon for each server?+                             modL install (Map.insertWith union (BinPkgName "artvaluereport2-server") (singleton ("theme/ArtValueReport_SunsetSpectrum.ico", "usr/share/artvaluereport2-data"))) $+                             modL Atoms.description (Map.insertWith (error "test6") (BinPkgName "artvaluereport2-backups")+                                                    (T.intercalate "\n"+                                                     [ "backup program for the appraisalreportonline.com site"+                                                     , "  Install this somewhere other than where the server is running get"+                                                     , "  automated backups of the database." ])) $+                             doBackups (BinPkgName "artvaluereport2-backups") "artvaluereport2-backups" $+                             doWebsite (BinPkgName "artvaluereport2-production") (theSite (BinPkgName "artvaluereport2-production")) $+                             doServer (BinPkgName "artvaluereport2-staging") (theServer (BinPkgName "artvaluereport2-staging")) $+                             doServer (BinPkgName "artvaluereport2-development") (theServer (BinPkgName "artvaluereport2-development")) $+                             flip (foldr (\ s deb -> modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-server") (singleton (anyrel (BinPkgName s)))) deb))+                                  ["libjs-jquery", "libjs-jquery-ui", "libjs-jcrop", "libjpeg-progs", "netpbm",+                                   "texlive-latex-recommended", "texlive-latex-extra", "texlive-fonts-recommended", "texlive-fonts-extra"] $+                             doExecutable (BinPkgName "artvaluereport2-server") (InstallFile "artvaluereport2-server" Nothing Nothing "artvaluereport2-server") $+                             setL changelog (getL changelog old) $+                             (newDebianization' 7 (StandardsVersion 3 9 1 Nothing)))+                  writeDebianization "/tmp" new+                  assertEqual "test6" [] (diffDebianizations old (copyFirstLogEntry old new)))+    where+      -- hints = dependencyHints (putExecMap "trhsx" (BinPkgName "haskell-hsx-utils") $ putExtraDevDep (BinPkgName "markdown") $ Flags.defaultFlags)+      -- A log entry gets added when the Debianization is generated,+      -- it won't match so drop it for the comparison.+      -- dropFirstLogEntry (deb@(Debianization {changelog = ChangeLog (_ : tl)})) = deb {changelog = ChangeLog tl}+      theSite :: BinPkgName -> Site+      theSite deb =+          Site { domain = hostname'+               , serverAdmin = "logic@seereason.com"+               , server = theServer deb }+      theServer :: BinPkgName -> Server+      theServer deb =+          Server { hostname =+                       case deb of+                         BinPkgName "artvaluereport2-production" -> hostname'+                         _ -> hostname'+                 , port = portNum deb+                 , headerMessage = "Generated by artvaluereport2/Setup.hs"+                 , retry = "60"+                 , serverFlags =+                    ([ "--http-port", show (portNum deb)+                     , "--base-uri", case deb of+                                       BinPkgName "artvaluereport2-production" -> "http://" ++ hostname' ++ "/"+                                       _ -> "http://seereason.com:" ++ show (portNum deb) ++ "/"+                     , "--top", databaseDirectory deb+                     , "--logs", "/var/log/" ++ show (pretty deb)+                     , "--log-mode", case deb of+                                       BinPkgName "artvaluereport2-production" -> "Production"+                                       _ -> "Development"+                     , "--static", "/usr/share/artvaluereport2-data"+                     , "--no-validate" ] +++                     (case deb of+                        BinPkgName "artvaluereport2-production" -> [{-"--enable-analytics"-}]+                        _ -> []) {- +++                     [ "--jquery-path", "/usr/share/javascript/jquery/"+                     , "--jqueryui-path", "/usr/share/javascript/jquery-ui/"+                     , "--jstree-path", jstreePath+                     , "--json2-path",json2Path ] -})+                 , installFile =+                     InstallFile { execName   = "artvaluereport2-server"+                                 , destName   = show (pretty deb)+                                 , sourceDir  = Nothing+                                 , destDir    = Nothing }+                 }+      hostname' = "my.appraisalreportonline.com"+      portNum :: BinPkgName -> Int+      portNum (BinPkgName deb) =+          case deb of+            "artvaluereport2-production"  -> 9027+            "artvaluereport2-staging"     -> 9031+            "artvaluereport2-development" -> 9032+            _ -> error $ "Unexpected package name: " ++ deb++test7 :: Test+test7 =+    TestLabel "test7" $+    TestCase ( do old <- inputDebianization "."+                  new <- debianization "."+                           (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) $+                            setL sourceFormat (Just Native3) $+                            setL utilsPackageName (Just (BinPkgName "cabal-debian")) $+                            modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (anyrel (BinPkgName "apt-file")))) $+                            modL Atoms.conflicts (Map.insertWith union (BinPkgName "cabal-debian")+                                    (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) $+                            modL Atoms.description (Map.insertWith (error "test7") (BinPkgName "cabal-debian")+                                                    (T.intercalate "\n"+                                                      [ "Create a debianization for a cabal package"+                                                      , " Tool for creating debianizations of Haskell packages based on the .cabal"+                                                      , " file.  If apt-file is installed it will use it to discover what is the"+                                                      , " debian package name of a C library."+                                                      , " ."+                                                      , "  Author: David Fox <dsf@seereason.com>"+                                                      , "  Upstream-Maintainer: David Fox <dsf@seereason.com>" ])) $+                            copyChangelog old $+                            newDebianization' 7 (StandardsVersion 3 9 3 Nothing))+                  assertEqual "test7" [] (diffDebianizations old (copyChangelog old new)))++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) $+                            (newDebianization' 7 (StandardsVersion 3 9 3 Nothing)))+                  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/"}) $+                            (\ atoms -> foldr (\ name atoms -> modL installData (Map.insertWith union (BinPkgName "alex") (singleton (name, name))) atoms)+                                              atoms+                                              [ "AlexTemplate"+                                              , "AlexTemplate-debug"+                                              , "AlexTemplate-ghc"+                                              , "AlexTemplate-ghc-debug"+                                              , "AlexWrapper-basic"+                                              , "AlexWrapper-basic-bytestring"+                                              , "AlexWrapper-gscan"+                                              , "AlexWrapper-monad"+                                              , "AlexWrapper-monad-bytestring"+                                              , "AlexWrapper-monadUserState"+                                              , "AlexWrapper-monadUserState-bytestring"+                                              , "AlexWrapper-posn"+                                              , "AlexWrapper-posn-bytestring"+                                              , "AlexWrapper-strict-bytestring"]) $+                            newDebianization' 7 (StandardsVersion 3 9 3 Nothing))+                  assertEqual "test9" [] (diffDebianizations old (copyFirstLogEntry old new)))++data Change k a+    = Created k a+    | Deleted k a+    | Modified k a a+    | Unchanged k a+    deriving (Eq, Show)++diffMaps :: (Ord k, Eq a, Show k, Show a) => Map.Map k a -> Map.Map k a -> [Change k a]+diffMaps old new =+    Map.elems (intersectionWithKey combine1 old new) +++    map (uncurry Deleted) (Map.toList (differenceWithKey combine2 old new)) +++    map (uncurry Created) (Map.toList (differenceWithKey combine2 new old))+    where+      combine1 k a b = if a == b then Unchanged k a else Modified k a b+      combine2 _ _ _ = Nothing++diffDebianizations :: Atoms -> Atoms -> String -- [Change FilePath T.Text]+diffDebianizations old new =+    show (mconcat (map prettyChange (filter (not . isUnchanged) (diffMaps old' new'))))+    where+      old' = toFileMap (sortBinaryDebs old) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ old))+      new' = toFileMap (sortBinaryDebs new) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ new))+      isUnchanged (Unchanged _ _) = True+      isUnchanged _ = False+      prettyChange (Unchanged p _) = text ("Unchanged: " <> p <> "\n")+      prettyChange (Deleted p _) = text ("Deleted: " <> p <> "\n")+      prettyChange (Created p b) =+          text ("Created: " <> p <> "\n") <>+          prettyDiff ("old" </> p) ("new" </> p)+                     -- We use split here instead of lines so we can+                     -- detect whether the file has a final newline+                     -- character.+                     (contextDiff 2 mempty (T.split (== '\n') b))+      prettyChange (Modified p a b) =+          text ("Modified: " <> p<> "\n") <>+          prettyDiff ("old" </> p) ("new" </> p)+                     -- We use split here instead of lines so we can+                     -- detect whether the file has a final newline+                     -- character.+                     (contextDiff 2 (T.split (== '\n') a) (T.split (== '\n') b))+      sortBinaryDebs atoms = modL control (\ deb -> deb {binaryPackages = sortBy (compare `on` package) (binaryPackages deb)}) atoms++testEntry :: ChangeLogEntry+testEntry =+    either (error "Error in test changelog entry") fst+           (parseEntry (unlines [ "haskell-cabal-debian (2.6.2) unstable; urgency=low"+                                , ""+                                , "  * Fix a bug constructing the destination pathnames that was dropping"+                                , "    files that were supposed to be installed into packages."+                                , ""+                                , " -- David Fox <dsf@seereason.com>  Thu, 20 Dec 2012 06:49:25 -0800" ]))
+ src/Debian/Debianize/Types.hs view
@@ -0,0 +1,66 @@+module Debian.Debianize.Types+    ( 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)++data PackageInfo = PackageInfo { cabalName :: PackageName+                               , devDeb :: Maybe (BinPkgName, DebianVersion)+                               , profDeb :: Maybe (BinPkgName, DebianVersion)+                               , docDeb :: Maybe (BinPkgName, DebianVersion) } deriving (Eq, Ord, Show)++-- | Information about the web site we are packaging.+data Site+    = Site+      { domain :: String   -- ^ The domain name assigned to the server.+                           -- An apache configuration will be generated to+                           -- redirect requests from this domain to hostname:port+      , serverAdmin :: String   -- ^ Apache ServerAdmin parameter+      , server :: Server   -- ^ The hint to install the server job+      } deriving (Read, Show, Eq, Ord)++-- | Information about the server we are packaging.+data Server+    = Server+      { hostname :: String      -- ^ Host on which the server will run+      , port :: Int             -- ^ Port on which the server will run.+                                -- Obviously, this must assign each and+                                -- every server package to a different+                                -- port.+      , headerMessage :: String -- ^ A comment that will be inserted to+                                -- explain how the file was generated+      , retry :: String         -- ^ start-stop-daemon --retry argument+      , serverFlags :: [String] -- ^ Extra flags to pass to the server via the init script+      , installFile :: InstallFile -- ^ The hint to install the server executable+      } deriving (Read, Show, Eq, Ord)++data InstallFile+    = InstallFile+      { execName :: String -- ^ The name of the executable file+      , sourceDir :: Maybe FilePath -- ^ where to find it, default is dist/build/<execName>/+      , 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)++-- | A redundant data type, too lazy to expunge.+data DebType = Dev | Prof | Doc deriving (Eq, Ord, Read, Show)
+ src/Debian/Debianize/Utility.hs view
@@ -0,0 +1,231 @@+-- | Functions used by but not related to cabal-debian, these could+-- conceivably be moved into more general libraries.+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Debian.Debianize.Utility+    ( DebMap+    , buildDebVersionMap+    , (!)+    , trim+    , strictReadF+    , replaceFile+    , modifyFile+    , diffFile+    , removeIfExists+    , dpkgFileMap+    , cond+    , debOfFile+    , readFile'+    , showDeps+    , showDeps'+    , withCurrentDirectory+    , getDirectoryContents'+    , setMapMaybe+    , zipMaps+    , foldEmpty+    , maybeL+    , indent+    ) where++import Control.Exception as E (catch, try, bracket, IOException)+import Control.Monad (when)+import Control.Monad.Reader (ReaderT, ask)+import Data.Char (isSpace)+import Data.List as List (isSuffixOf, intercalate, map, lines)+import Data.Lens.Lazy (Lens, modL)+import Data.Map as Map (Map, foldWithKey, empty, fromList, findWithDefault, insert, map, lookup)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Set (Set, toList)+import qualified Data.Set as Set+import Data.Text as Text (Text, unpack, lines)+import Data.Text.IO (hGetContents)+import Debian.Control (parseControl, lookupP, Field'(Field), unControl, stripWS)+import Debian.Version (DebianVersion, prettyDebianVersion)+import Debian.Version.String (parseDebianVersion)+import qualified Debian.Relation as D+import Prelude hiding (map, lookup)+import System.Directory (doesFileExist, doesDirectoryExist, removeFile, renameFile, removeDirectory, getDirectoryContents, getCurrentDirectory, setCurrentDirectory)+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.Process (readProcessWithExitCode, showCommandForUser)+import Text.PrettyPrint.ANSI.Leijen (pretty)++type DebMap = Map.Map D.BinPkgName (Maybe DebianVersion)++-- | Read and parse the status file for installed debian packages.+buildDebVersionMap :: IO DebMap+buildDebVersionMap =+    readFile "/var/lib/dpkg/status" >>=+    return . either (const []) unControl . parseControl "/var/lib/dpkg/status" >>=+    mapM (\ p -> case (lookupP "Package" p, lookupP "Version" p) of+                   (Just (Field (_, name)), Just (Field (_, version))) ->+                       return (Just (D.BinPkgName (stripWS name), Just (parseDebianVersion (stripWS version))))+                   _ -> return Nothing) >>=+    return . Map.fromList . catMaybes++(!) :: DebMap -> D.BinPkgName -> DebianVersion+m ! k = maybe (error ("No version number for " ++ (show . pretty $ k) ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)++trim :: String -> String+trim = dropWhile isSpace++strictReadF :: (Text -> r) -> FilePath -> IO r+strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x))+-- strictRead = strictReadF id++-- | Write a file which we might still be reading from in+-- order to compute the text argument.+replaceFile :: FilePath -> String -> IO ()+replaceFile path text =+    do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))+       renameFile path back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))+       writeFile path text+    where+      back = path ++ "~"++-- | Compute the new file contents from the old.  If f returns Nothing+-- do not write.+modifyFile :: FilePath -> (String -> IO (Maybe String)) -> IO ()+modifyFile path f =+    do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))+       try (renameFile path back) >>=+           either (\ (e :: IOException) -> if not (isDoesNotExistError e)+                                           then ioError e+                                           else f "" >>= maybe (return ()) (writeFile path))+                  (\ () -> readFile back >>= f >>= maybe (return ()) (writeFile path))+    where+      back = path ++ "~"++diffFile :: FilePath -> Text -> IO (Maybe String)+diffFile path text =+    readProcessWithExitCode cmd args (unpack text) >>= \ (code, out, _err) ->+    case code of+      ExitSuccess -> return Nothing+      ExitFailure 1 -> return (Just out)+      _ -> error (showCommandForUser cmd args {- ++ " < " ++ show text -} ++ " -> " ++ show code)+    where+      cmd = "diff"+      args = ["-ruw", path, "-"]++removeFileIfExists :: FilePath -> IO ()+removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x))++removeDirectoryIfExists :: FilePath -> IO ()+removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x))++removeIfExists :: FilePath -> IO ()+removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x++-- |Create a map from pathname to the names of the packages that contains that pathname.+-- We need to make sure we consume all the files, so +dpkgFileMap :: IO (Map.Map FilePath (Set.Set D.BinPkgName))+dpkgFileMap =+    do+      let fp = "/var/lib/dpkg/info"+      names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list")+      let paths = List.map (fp </>) names+      files <- mapM (strictReadF Text.lines) paths+      return $ Map.fromList $ zip (List.map dropExtension names) (List.map (Set.fromList . List.map (D.BinPkgName . unpack)) $ files)++-- |Given a path, return the name of the package that owns it.+debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe D.BinPkgName)+debOfFile path =+    do mp <- ask+       return $ testPath (lookup path mp)+    where+      -- testPath :: Maybe (Set.Set FilePath) -> Maybe FilePath+      testPath Nothing = Nothing+      testPath (Just s) =+          case Set.size s of+            1 -> Just (Set.findMin s)+            _ -> Nothing++cond :: t -> t -> Bool -> t+cond ifF _ifT False = ifF+cond _ifF ifT True = ifT++readFile' :: FilePath -> IO Text+readFile' path =+    do file <- openFile path ReadMode+       hSetBinaryMode file True+       hGetContents file++-- Would like to call pretty instead of D.prettyRelations, but the+-- Pretty instance for [a] doesn't work for us.+showDeps :: [[D.Relation]] -> String+showDeps = show . D.prettyRelations++-- The extra space after prefix' is here for historical reasons(?)+showDeps' :: [a] -> [[D.Relation]] -> String+showDeps' prefix xss =+    intercalate  ("\n" ++ prefix' ++ " ") . Prelude.lines . show . D.prettyRelations $ xss+    where prefix' = List.map (\ _ -> ' ') prefix++-- | From Darcs.Utils+withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory name m =+    E.bracket+        (do cwd <- getCurrentDirectory+            setCurrentDirectory name+            return cwd)+        (\oldwd -> setCurrentDirectory oldwd {- `catchall` return () -})+        (const m)++{-+catchall :: IO a -> IO a -> IO a+a `catchall` b = a `catchNonSignal` (\_ -> b)++-- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows+-- us to catch anything but a signal.  Useful for situations where we want+-- don't want to inhibit ctrl-C.++catchNonSignal :: IO a -> (E.SomeException -> IO a) -> IO a+catchNonSignal comp handler = catch comp handler'+    where handler' se =+           case fromException se :: Maybe SignalException of+             Nothing -> handler se+             Just _ -> E.throw se++newtype SignalException = SignalException Signal deriving (Show, Typeable)++instance Exception SignalException where+   toException e = SomeException e+   fromException (SomeException e) = cast e+-}++getDirectoryContents' :: FilePath -> IO [FilePath]+getDirectoryContents' dir =+    getDirectoryContents dir >>= return . filter (not . dotFile)+    where+      dotFile "." = True+      dotFile ".." = True+      dotFile _ = False++setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b+setMapMaybe p = Set.fromList . mapMaybe p . toList++zipMaps :: Ord k => (k -> Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b -> Map k c+zipMaps f m n =+    foldWithKey h (foldWithKey g empty m) n+    where+      g k a r = case f k (Just a) (lookup k n) of+                  Just c -> Map.insert k c r              -- Both m and n have entries for k+                  Nothing -> r                            -- Only m has an entry for k+      h k b r = case lookup k m of+                  Nothing -> case f k Nothing (Just b) of+                               Just c -> Map.insert k c r -- Only n has an entry for k+                               Nothing -> r+                  Just _ -> r++foldEmpty :: r -> ([a] -> r) -> [a] -> r+foldEmpty r _ [] = r+foldEmpty _ f l = f l++-- | If the current value of getL x is Nothing, replace it with f.+maybeL :: Lens a (Maybe b) -> Maybe b -> a -> a+maybeL lens mb x = modL lens (maybe mb Just) x++indent :: [Char] -> String -> String+indent prefix text = unlines (List.map (prefix ++) (List.lines text))
+ src/Debian/Orphans.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Debian.Orphans where++import Data.Function (on)+import Data.Generics (Data, Typeable)+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text, unpack)+import Data.Version (Version(..), showVersion)+import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))+import Debian.Control (Field'(..))+import Debian.Relation (Relation(..), VersionReq(..), ArchitectureReq(..),+                        BinPkgName(..), SrcPkgName(..))+import Debian.Version (DebianVersion, prettyDebianVersion, parseDebianVersion)+import Distribution.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.License (License(..))+import Distribution.PackageDescription (PackageDescription(package), Executable(..))+import Distribution.Simple.Compiler (Compiler(..))+import Distribution.Version (VersionRange(..), foldVersionRange')+import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..))+import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text)+import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..))++deriving instance Typeable Compiler+deriving instance Typeable CompilerId+deriving instance Typeable CompilerFlavor+deriving instance Typeable Language+deriving instance Typeable Extension+deriving instance Typeable KnownExtension++deriving instance Data Extension+deriving instance Data KnownExtension+deriving instance Data Language+deriving instance Data Compiler+deriving instance Data CompilerId+deriving instance Data CompilerFlavor++deriving instance Ord Language+deriving instance Ord KnownExtension+deriving instance Ord Extension+deriving instance Eq Compiler+deriving instance Ord Compiler+deriving instance Ord NameAddr+deriving instance Ord License++instance Ord Executable where+    compare = compare `on` exeName++instance Ord PackageDescription where+    compare = compare `on` package++instance Pretty Text where+    pretty = text . unpack++{-+instance Show (Control' String) where+    show _ = "<control file>"++instance Show ChangeLog where+    show _ = "<log entry>"+-}++deriving instance Read ArchitectureReq+deriving instance Read BinPkgName+deriving instance Read ChangeLog+deriving instance Read ChangeLogEntry+deriving instance Read Relation+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++deriving instance Data ArchitectureReq+deriving instance Data BinPkgName+deriving instance Data ChangeLog+deriving instance Data ChangeLogEntry+-- deriving instance Data NameAddr+deriving instance Data Relation+deriving instance Data SrcPkgName+deriving instance Data VersionReq++deriving instance Typeable ArchitectureReq+deriving instance Typeable BinPkgName+deriving instance Typeable ChangeLog+deriving instance Typeable ChangeLogEntry+-- deriving instance Typeable NameAddr+deriving instance Typeable Relation+deriving instance Typeable SrcPkgName+deriving instance Typeable VersionReq++deriving instance Ord ChangeLog+deriving instance Ord ChangeLogEntry++{-+instance Pretty SrcPkgName where+    pretty (SrcPkgName x) = pretty x++instance Pretty BinPkgName where+    pretty (BinPkgName x) = pretty x+-}++deriving instance Typeable License+deriving instance Data Version+deriving instance Data License++-- Convert from license to RPM-friendly description.  The strings are+-- taken from TagsCheck.py in the rpmlint distribution.+instance Pretty License where+    pretty (GPL _) = text "GPL"+    pretty (LGPL _) = text "LGPL"+    pretty (Apache _) = text "Apache"+    pretty BSD3 = text "BSD"+    pretty BSD4 = text "BSD-like"+    pretty PublicDomain = text "Public Domain"+    pretty AllRightsReserved = text "Proprietary"+    pretty OtherLicense = text "Non-distributable"+    pretty MIT = text "MIT"+    pretty (UnknownLicense _) = text "Unknown"++deriving instance Data NameAddr+deriving instance Typeable NameAddr+deriving instance Read NameAddr++-- This Pretty instance gives a string used to create a valid+-- changelog entry, it *must* have a name followed by an email address+-- in angle brackets.+instance Pretty NameAddr where+    pretty x = text (fromMaybe (nameAddr_addr x) (nameAddr_name x) ++ " <" ++ nameAddr_addr x ++ ">")+    -- pretty x = text (maybe (nameAddr_addr x) (\ n -> n ++ " <" ++ nameAddr_addr x ++ ">") (nameAddr_name x))++deriving instance Show (Field' String)++instance Pretty VersionRange where+    pretty range =+        foldVersionRange'+          (text "*")+          (\ v -> text "=" <> pretty v)+          (\ v -> text ">" <> pretty v)+          (\ v -> text "<" <> pretty v)+          (\ v -> text ">=" <> pretty v)+          (\ v -> text "<=" <> pretty v)+          (\ x _ -> text "=" <> pretty x <> text ".*") -- not exactly right+          (\ x y -> text "(" <> x <> text " || " <> y <> text ")")+          (\ x y -> text "(" <> x <> text " && " <> y <> text ")")+          (\ x -> text "(" <> x <> text ")")+          range++instance Pretty Version where+    pretty = text . showVersion++instance Pretty DebianVersion where+    pretty = text . show
+ src/Debian/Policy.hs view
@@ -0,0 +1,233 @@+-- | Code pulled out of cabal-debian that straightforwardly implements+-- parts of the Debian policy manual, or other bits of Linux standards.+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module Debian.Policy+    ( -- * Paths+      databaseDirectory+    , apacheLogDirectory+    , apacheErrorLog+    , apacheAccessLog+    , serverLogDirectory+    , serverAppLog+    , serverAccessLog+    -- * Installed packages+    , debianPackageVersion+    , getDebhelperCompatLevel+    , StandardsVersion(..)+    , getDebianStandardsVersion+    , parseStandardsVersion+    -- * Package fields+    , SourceFormat(..)+    , readSourceFormat+    , PackagePriority(..)+    , readPriority+    , PackageArchitectures(..)+    , parsePackageArchitectures+    , Section(..)+    , readSection+    , Area(..)+    , parseUploaders+    , parseMaintainer+    , getDebianMaintainer+    , haskellMaintainer+    ) where++import Codec.Binary.UTF8.String (decodeString)+import Control.Arrow (second)+import Control.Monad (mplus)+import Data.Char (toLower, isSpace)+import Data.List (groupBy, intercalate)+import Data.Generics (Data, Typeable)+import Data.Text (Text, pack, unpack, strip)+import Data.Monoid ((<>))+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.PrettyPrint.ANSI.Leijen (Pretty(pretty), text)++databaseDirectory :: BinPkgName -> String+databaseDirectory x = "/srv" </> show (pretty x)++apacheLogDirectory :: BinPkgName -> String+apacheLogDirectory x =  "/var/log/apache2/" ++ show (pretty x)++apacheErrorLog :: BinPkgName -> String+apacheErrorLog x = apacheLogDirectory x </> "error.log"++apacheAccessLog :: BinPkgName -> String+apacheAccessLog x = apacheLogDirectory x </> "access.log"++serverLogDirectory :: BinPkgName -> String+serverLogDirectory x = "/var/log/" ++ show (pretty x)++serverAppLog :: BinPkgName -> String+serverAppLog x = serverLogDirectory x </> "app.log"++serverAccessLog :: BinPkgName -> String+serverAccessLog x = serverLogDirectory x </> "access.log"++debianPackageVersion :: String -> IO DebianVersion+debianPackageVersion name =+    readProcess "dpkg-query" ["--show", "--showformat=${version}", name] "" >>=+    return . parseDebianVersion++-- | Assumes debhelper is installed+getDebhelperCompatLevel :: IO Int+getDebhelperCompatLevel =+    debianPackageVersion "debhelper" >>= return . read . takeWhile (/= '.') . version++data StandardsVersion = StandardsVersion Int Int Int (Maybe Int) deriving (Eq, Ord, Show, Data, Typeable)++instance Pretty StandardsVersion where+    pretty (StandardsVersion a b c (Just d)) = text $ show a <> "." <> show b <> "." <> show c <> "." <> show d+    pretty (StandardsVersion a b c Nothing) = text $ show a <> "." <> show b <> "." <> show c++-- | Assumes debian-policy is installed+getDebianStandardsVersion :: IO StandardsVersion+getDebianStandardsVersion = debianPackageVersion "debian-policy" >>= \ v -> return (parseStandardsVersion (version v))++parseStandardsVersion :: String -> StandardsVersion+parseStandardsVersion s =+    case filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) s) of+      (a : b : c : d : _) -> StandardsVersion (read a) (read b) (read c) (Just (read d))+      (a : b : c : _) -> StandardsVersion (read a) (read b) (read c) Nothing+      _ -> error $ "Invalid Standards-Version string: " ++ show s++data SourceFormat+    = Native3+    | Quilt3+    deriving (Eq, Ord, Show, Data, Typeable)++instance Pretty SourceFormat where+    pretty Quilt3 = text "3.0 (quilt)\n"+    pretty Native3 = text "3.0 (native)\n"++readSourceFormat :: Text -> Either Text SourceFormat+readSourceFormat s =+    case () of+      _ | strip s == "3.0 (native)" -> Right Native3+      _ | strip s == "3.0 (quilt)" -> Right Quilt3+      _ -> Left $ "Invalid debian/source/format: " <> pack (show (strip s))++data PackagePriority+    = Required+    | Important+    | Standard+    | Optional+    | Extra+    deriving (Eq, Ord, Read, Show, Data, Typeable)++readPriority :: String -> PackagePriority+readPriority s =+    case unpack (strip (pack s)) of+      "required" -> Required+      "important" -> Important+      "standard" -> Standard+      "optional" -> Optional+      "extra" -> Extra+      x -> error $ "Invalid priority string: " ++ show x++instance Pretty PackagePriority where+    pretty = text . map toLower . show++-- | The architectures for which a binary deb can be built.+data PackageArchitectures+    = All            -- ^ The package is architecture independenct+    | Any            -- ^ The package can be built for any architecture+    | Names [String] -- ^ The list of suitable architectures+    deriving (Read, Eq, Ord, Show, Data, Typeable)++instance Pretty PackageArchitectures where+    pretty All = text "all"+    pretty Any = text "any"+    pretty (Names xs) = text $ intercalate " " xs++parsePackageArchitectures :: String -> PackageArchitectures+parsePackageArchitectures "all" = All+parsePackageArchitectures "any" = Any+parsePackageArchitectures s = error $ "FIXME: parsePackageArchitectures " ++ show s++data Section+    = MainSection String -- Equivalent to AreaSection Main s?+    | AreaSection Area String+    deriving (Read, Eq, Ord, Show, Data, Typeable)++readSection :: String -> Section+readSection s =+    case break (== '/') s of+      ("contrib", '/' : b) -> AreaSection Contrib (tail b)+      ("non-free", '/' : b) -> AreaSection NonFree (tail b)+      ("main", '/' : b) -> AreaSection Main (tail b)+      (a, '/' : _) -> error $ "readSection - unknown area: " ++ show a+      (a, _) -> MainSection a++instance Pretty Section where+    pretty (MainSection sec) = text sec+    pretty (AreaSection area sec) = pretty area <> text ("/" <> sec)++-- Is this really all that is allowed here?  Doesn't Ubuntu have different areas?+data Area+    = Main+    | Contrib+    | NonFree+    deriving (Read, Eq, Ord, Show, Data, Typeable)++instance Pretty Area where+    pretty Main = text "main"+    pretty Contrib = text "contrib"+    pretty NonFree = text "non-free"++{-+Create a debian maintainer field from the environment variables:++  DEBFULLNAME (preferred) or NAME+  DEBEMAIL (preferred) or EMAIL++More work could be done to match dch, but this is sufficient for+now. Here is what the man page for dch has to say:++ If the environment variable DEBFULLNAME is set, this will be used for+ the maintainer full name; if not, then NAME will be checked.  If the+ environment variable DEBEMAIL is set, this will be used for the email+ address.  If this variable has the form "name <email>", then the+ maintainer name will also be taken from here if neither DEBFULLNAME+ nor NAME is set.  If this variable is not set, the same test is+ performed on the environment variable EMAIL.  Next, if the full name+ has still not been determined, then use getpwuid(3) to determine the+ name from the pass‐word file.  If this fails, use the previous+ changelog entry.  For the email address, if it has not been set from+ DEBEMAIL or EMAIL, then look in /etc/mailname, then attempt to build+ it from the username and FQDN, otherwise use the email address in the+ previous changelog entry.  In other words, it’s a good idea to set+ DEBEMAIL and DEBFULLNAME when using this script.++-}+getDebianMaintainer :: IO (Maybe NameAddr)+getDebianMaintainer =+    do env <- map (second decodeString) `fmap` getEnvironment+       return $ do fullname <- lookup "DEBFULLNAME" env `mplus` lookup "NAME" env+                   email    <- lookup "DEBEMAIL" env `mplus` lookup "EMAIL" env+                   either (const Nothing) Just (parseMaintainer (fullname ++ " <" ++ email ++ ">"))++haskellMaintainer :: NameAddr+haskellMaintainer =+    either error id (parseMaintainer "Debian Haskell Group <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 (\ e -> error ("Failure parsing uploader list: " ++ show x ++ " -> " ++ show e)) id $ +    where+      fixWhite c = if isSpace c then ' ' else c++parseMaintainer :: String -> Either String NameAddr+parseMaintainer x =+    case parseUploaders x of+      Left s -> Left s+      Right [y] -> Right y+      Right [] -> Left $ "Missing maintainer: " ++ show x+      Right ys -> Left $ "Too many maintainers: " ++ show ys
+ src/Distribution/Version/Invert.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wall #-}+module Distribution.Version.Invert+    ( invertVersionRange+    , invertVersionIntervals+    ) where++import Distribution.Version (Version(Version, versionBranch, versionTags), VersionRange, fromVersionIntervals, asVersionIntervals, mkVersionIntervals,+                             LowerBound(LowerBound), UpperBound(UpperBound, NoUpperBound), Bound(InclusiveBound, ExclusiveBound))++invertVersionRange :: VersionRange -> VersionRange+invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals++invertVersionIntervals :: [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)]+invertVersionIntervals xs =+    case xs of+      [] -> [(lb0, NoUpperBound)]+      ((LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound, ub) : more) ->+          invertVersionIntervals' ub more+      ((lb, ub) : more) ->+          (lb0, invertLowerBound lb) : invertVersionIntervals' ub more+    where+      invertVersionIntervals' :: UpperBound -> [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)]+      invertVersionIntervals' NoUpperBound [] = []+      invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]+      invertVersionIntervals' ub0 [(lb, NoUpperBound)] = [(invertUpperBound ub0, invertLowerBound lb)]+      invertVersionIntervals' ub0 ((lb, ub1) : more) = (invertUpperBound ub0, invertLowerBound lb) : invertVersionIntervals' ub1 more++      invertLowerBound :: LowerBound -> UpperBound+      invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)++      invertUpperBound :: UpperBound -> LowerBound+      invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)+      invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"++      invertBound :: Bound -> Bound+      invertBound ExclusiveBound = InclusiveBound+      invertBound InclusiveBound = ExclusiveBound++      lb0 :: LowerBound+      lb0 = LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound
+ src/Tests.hs view
@@ -0,0 +1,7 @@+module Main where++import Debian.Debianize.Tests (tests)+import Test.HUnit (runTestTT)++main :: IO ()+main = runTestTT tests >>= putStrLn . show
+ src/Triplets.hs view
@@ -0,0 +1,306 @@+{-# 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