diff --git a/CabalDebian.hs b/CabalDebian.hs --- a/CabalDebian.hs +++ b/CabalDebian.hs @@ -1,56 +1,16 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | 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 Control.Category ((.)) -import Control.Lens (view) -import Control.Monad.State (get) -import Control.Monad.Trans (MonadIO, liftIO) -import Data.List as List (unlines) -import Debian.Debianize.BasicInfo (DebAction(Debianize, SubstVar, Usage), debAction, newFlags) -import Debian.Debianize.CabalInfo (newCabalInfo, debInfo) -import Debian.Debianize.DebInfo (flags) +import Control.Monad.State (evalStateT) +import Debian.Debianize.BasicInfo (newFlags) +import Debian.Debianize.CabalInfo (newCabalInfo) import Debian.Debianize.Details (debianDefaults) import Debian.Debianize.Finalize (debianize) -import Debian.Debianize.Monad (CabalT, evalCabalT, liftCabal) -import Debian.Debianize.Options (options) -import Debian.Debianize.Output (doDebianizeAction) -import Debian.Debianize.SubstVars (substvars) -import Prelude hiding (unlines, writeFile, init, (.)) -import System.Console.GetOpt (OptDescr, usageInfo) -import System.Environment (getProgName) +import Debian.Debianize.Output (finishDebianization) main :: IO () -main = cabalDebianMain debianDefaults - --- | The main function for the cabal-debian executable. -cabalDebianMain :: (MonadIO m, Functor m) => CabalT m () -> m () -cabalDebianMain init = - -- This picks up the options required to decide what action we are - -- taking. Much of this will be repeated in the call to debianize. - do atoms <- liftIO $ newFlags >>= newCabalInfo - evalCabalT (do debianize init - action <- get >>= return . view (debInfo . flags . debAction) - finish action) atoms +main = newFlags >>= newCabalInfo >>= evalStateT cabalDebian where - finish :: forall m. (MonadIO m, Functor m) => DebAction -> CabalT m () - finish (SubstVar debType) = substvars debType - finish Debianize = liftCabal doDebianizeAction - finish Usage = do - progName <- liftIO getProgName - let info = unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: " - , "" - , " " ++ progName ++ " --maintainer 'Maintainer Name '." - , "" - , "This will read the package's cabal file and any existing debian/changelog file and" - , "deduce what it can about the debianization, then it will create or modify files in" - , "the debian subdirectory. Note that it will not remove any files in debian, and" - , "these could affect the operation of the debianization in unknown ways. For this" - , "reason I recommend either using a pristine unpacked directory each time, or else" - , "using a revision control system to revert the package to a known state before running." - , "The following additional options are available:" ] - liftIO $ putStrLn (usageInfo info (options :: [OptDescr (CabalT m ())])) + cabalDebian = do + -- Read and inspect the cabal info to compute the debianization + debianize debianDefaults + -- Write, compare, or validate the resulting debianization, + -- or print usage message, depending on options. + finishDebianization diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -8,8 +8,7 @@ import OldLens (getL, setL) import Control.Applicative ((<$>)) -import Data.Algorithm.Diff.Context (contextDiff) -import Data.Algorithm.Diff.Pretty (prettyDiff) +import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) import Data.Function (on) import Data.List (sortBy) import Data.Map as Map (differenceWithKey, intersectionWithKey) @@ -703,15 +702,15 @@ prettyChange (Deleted p _) = text "Deleted: " <> pPrint p <> text "\n" prettyChange (Created p b) = text "Created: " <> pPrint p <> text "\n" <> - prettyDiff (text ("old" p)) (text ("new" p)) (text . unpack) + prettyContextDiff (text ("old" p)) (text ("new" p)) (text . unpack) -- We use split here instead of lines so we can -- detect whether the file has a final newline -- character. - (contextDiff 2 mempty (split (== '\n') b)) + (getContextDiff 2 mempty (split (== '\n') b)) prettyChange (Modified p a b) = text "Modified: " <> pPrint p <> text "\n" <> - prettyDiff (text ("old" p)) (text ("new" p)) (text . unpack) - (contextDiff 2 (split (== '\n') a) (split (== '\n') b)) + prettyContextDiff (text ("old" p)) (text ("new" p)) (text . unpack) + (getContextDiff 2 (split (== '\n') a) (split (== '\n') b)) sortBinaryDebs :: DebianT IO () sortBinaryDebs = (D.control . S.binaryPackages) %= sortBy (compare `on` getL B.package) diff --git a/cabal-debian.cabal b/cabal-debian.cabal --- a/cabal-debian.cabal +++ b/cabal-debian.cabal @@ -1,5 +1,5 @@ Name: cabal-debian -Version: 4.24.6 +Version: 4.24.8 Copyright: Copyright (c) 2007-2014, David Fox, Jeremy Shaw License: BSD3 License-File: LICENSE @@ -145,6 +145,10 @@ Default: False Manual: True +flag pretty-112 + Description: prettyclass was merged into pretty-1.1.2 + Default: True + Source-Repository head type: git location: https://github.com/ddssff/cabal-debian @@ -158,18 +162,16 @@ containers, data-default, deepseq, - Diff, + Diff >= 0.3.1, directory, filepath, hsemail, HUnit, lens, - memoize, + memoize >= 0.7, mtl, network-uri, parsec >= 3, - pretty, - prettyclass, process, pureMD5, regex-tdfa, @@ -180,8 +182,6 @@ Unixutils, utf8-string Exposed-Modules: - Data.Algorithm.Diff.Context - Data.Algorithm.Diff.Pretty Debian.GHC Debian.Policy Distribution.Version.Invert @@ -207,12 +207,15 @@ Debian.Debianize.Output Debian.Debianize.Prelude Debian.Debianize.SourceDebDescription - Debian.Debianize.SubstVars Debian.Debianize.VersionSplits OldLens Paths_cabal_debian Other-Modules: Debian.Orphans + if flag(pretty-112) + Build-Depends: pretty >= 1.1.2 + else + Build-Depends: pretty < 1.1.2, prettyclass if flag(local-debian) Hs-Source-Dirs: debian-haskell Build-Depends: @@ -270,17 +273,25 @@ Build-depends: debian >= 3.87 Executable cabal-debian - Hs-Source-Dirs: . - Main-is: CabalDebian.hs - ghc-options: -threaded -Wall -O2 - Build-Depends: base, cabal-debian, Cabal >= 1.18, lens, mtl, pretty - if !flag(local-debian) - Build-Depends: debian >= 3.87 + Hs-Source-Dirs: . + Main-is: CabalDebian.hs + ghc-options: -threaded -Wall -O2 + Build-Depends: base, cabal-debian, Cabal >= 1.18, lens, mtl, pretty + if flag(pretty-112) + Build-Depends: pretty >= 1.1.2 + else + Build-Depends: pretty < 1.1.2, prettyclass + if !flag(local-debian) + Build-Depends: debian >= 3.87 Executable cabal-debian-tests - Hs-Source-Dirs: . - Main-is: Tests.hs - ghc-options: -threaded -Wall -O2 - Build-Depends: base, cabal-debian, Cabal >= 1.18, containers, filepath, hsemail, HUnit, lens, prettyclass, process, text - if !flag(local-debian) - Build-Depends: debian >= 3.87 + Hs-Source-Dirs: . + Main-is: Tests.hs + ghc-options: -threaded -Wall -O2 + Build-Depends: base, cabal-debian, Cabal >= 1.18, containers, Diff >= 0.3.1, filepath, hsemail, HUnit, lens, process, text + if flag(pretty-112) + Build-Depends: pretty >= 1.1.2 + else + Build-Depends: pretty < 1.1.2, prettyclass + if !flag(local-debian) + Build-Depends: debian >= 3.87 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,25 @@ +haskell-cabal-debian (4.24.8) unstable; urgency=low + + * use ghcjs --numeric-ghc-version to set the compilerInfoCompat field + of CompilerInfo. This makes cabal file directives like impl(ghc >= 7.9) + work for ghcjs packages. + + -- David Fox Sun, 29 Mar 2015 12:38:33 -0700 + +haskell-cabal-debian (4.24.7) unstable; urgency=low + + * Remove the Data.Algorithm.Diff modules, they have moved into Diff-0.3.1 + + -- David Fox Tue, 24 Mar 2015 16:51:29 -0700 + +haskell-cabal-debian (4.24.6) unstable; urgency=low + + * Use build dependency haskell-devscripts >= 0.8 for unofficial, >= 0.9 + for official. + * Straighten out the test suite options: --no-tests, --no-run-tests + + -- David Fox Mon, 23 Mar 2015 11:31:14 -0700 + haskell-cabal-debian (4.24.5) unstable; urgency=low * Patch from Dmitry Bogatov for filling in debian/copyright fields diff --git a/debian-haskell/Debian/Apt/Dependencies.hs b/debian-haskell/Debian/Apt/Dependencies.hs --- a/debian-haskell/Debian/Apt/Dependencies.hs +++ b/debian-haskell/Debian/Apt/Dependencies.hs @@ -3,7 +3,7 @@ module Debian.Apt.Dependencies {- ( solve - , State + , State , binaryDepends , search , bj' @@ -27,7 +27,7 @@ -- * Basic CSP Types and Functions -data Status +data Status = Remaining AndRelation | MissingDep Relation | Complete @@ -87,13 +87,13 @@ let preDepends = case lookupP "Pre-Depends" p of Nothing -> [] - Just (Field (_,pd)) -> + Just (Field (_,pd)) -> either (error . show) id (parseRelations pd) Just (Comment _) -> error "depF" depends = case lookupP "Depends" p of Nothing -> [] - Just (Field (_,pd)) -> + Just (Field (_,pd)) -> either (error . show) id (parseRelations pd) Just (Comment _) -> error "depF" in @@ -207,7 +207,7 @@ -- |earliestInconsistency does what it sounds like -- the 'reverse as' is because the vars are order high to low, but we -- want to find the lowest numbered (aka, eariest) inconsistency ?? --- +-- earliestInconsistency :: CSP a -> State a -> Maybe ((BinPkgName, DebianVersion), (BinPkgName, DebianVersion)) earliestInconsistency _ (_,[]) = Nothing earliestInconsistency _ (_,[_p]) = Nothing @@ -262,7 +262,7 @@ | isConflict cs = mkTree (s, cs) ts -- | isConflict cs' = mkTree (s, cs') [] -- prevent space leak | otherwise = mkTree (s, cs') ts - where cs' = + where cs' = let set = combine csp (map label ts) [] in set `seq` set -- prevent space leak @@ -275,7 +275,7 @@ | (not (lastvar `elem` c)) && null m = cs | null c && null m = ([],[]) -- is this case ever used? | otherwise = combine csp ns ((c, m):acc) - where lastvar = + where lastvar = let (_,(p:_)) = s in (packageVersion csp) p diff --git a/debian-haskell/Debian/Apt/Index.hs b/debian-haskell/Debian/Apt/Index.hs --- a/debian-haskell/Debian/Apt/Index.hs +++ b/debian-haskell/Debian/Apt/Index.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Apt.Index ( update @@ -52,7 +52,7 @@ = BZ2 | GZ | Uncompressed deriving (Read, Show, Eq, Ord, Enum, Bounded) -data CheckSums +data CheckSums = CheckSums { md5sum :: Maybe String , sha1 :: Maybe String , sha256 :: Maybe String @@ -66,10 +66,10 @@ -- A good choice might be a partially parameterized call to -- 'Debian.Apt.Methods.fetch' type Fetcher = - URI -> -- remote URI - FilePath -> -- local file name - Maybe UTCTime -> -- optional time stamp for local file - IO Bool -- True on success, False on failure + URI -> -- remote URI + FilePath -> -- local file name + Maybe UTCTime -> -- optional time stamp for local file + IO Bool -- True on success, False on failure -- |update - similar to apt-get update @@ -78,12 +78,12 @@ -- in \/var\/lib\/apt\/lists. You can almost use this function instead of -- calling apt-get update. However there are a few key differences: -- 1. apt-get update also updates the binary cache files --- 2. apt-get update uses the partial directory and lock file in\ /var\/lib\/apt\/lists +-- 2. apt-get update uses the partial directory and lock file in\ /var\/lib\/apt\/lists -- 3. apt-get update downloads the Release and Release.gpg files update :: Fetcher -- ^ function that will do actually downloading -> FilePath -- ^ download indexes to the directory (must already exist) -> String -- ^ binary architecture - -> [DebSource] -- ^ sources.list + -> [DebSource] -- ^ sources.list -> IO [Maybe (FilePath, Compression)] -- ^ (basename of index file, compression status) update fetcher basePath arch sourcesList = mapM (uncurry $ fetchIndex fetcher) (map (\(uri, fp, _) -> (uri, (basePath fp))) (concatMap (indexURIs arch) sourcesList)) @@ -126,7 +126,7 @@ (release, sections) = either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint debSource)) id (sourceDist debSource) --- |return a tuple for the section +-- |return a tuple for the section -- - the URI to the uncompressed index file -- - the basename that apt-get uses for the downloaded index -- FIXME: support for Release and Release.gpg @@ -204,7 +204,7 @@ combine = (\x y -> sortBy (compare `on` snd) (x ++ y)) {- with t@(_,_,fp) m = - let (un, compression) = + let (un, compression) = in M.insertWith -} @@ -238,7 +238,7 @@ do indexes' <- mapM (filterExists distDir) (filter (isType iType) indexes) return $ map (head . snd) (filter (not . List.null . snd) indexes') where - isType iType (fp, _) = iType `isSuffixOf` fp + isType iType (fp, _) = iType `isSuffixOf` fp {- findIndexes' :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] @@ -268,7 +268,7 @@ indexesInRelease :: (FilePath -> Bool) -> Control' Text -- ^ A release file - -> [(CheckSums, Integer, FilePath)] -- ^ + -> [(CheckSums, Integer, FilePath)] -- ^ indexesInRelease filterp (Control [p]) = let md5sums = case md5sumField p of diff --git a/debian-haskell/Debian/Apt/Methods.hs b/debian-haskell/Debian/Apt/Methods.hs --- a/debian-haskell/Debian/Apt/Methods.hs +++ b/debian-haskell/Debian/Apt/Methods.hs @@ -138,13 +138,13 @@ | a == "Pipeline" = c { pipeline = parseTrueFalse v } | a == "Send-Config" = c { sendConfig = parseTrueFalse v } | a == "Needs-Cleanup" = c { needsCleanup = parseTrueFalse v } - | a == "Local-Only" = c { localOnly = parseTrueFalse v } + | a == "Local-Only" = c { localOnly = parseTrueFalse v } | otherwise = error $ "unknown capability: " ++ show (a,v) defaultCapabilities = Capabilities { version = "" , singleInstance = False - , preScan = False - , pipeline = False + , preScan = False + , pipeline = False , sendConfig = False , needsCleanup = False , localOnly = False diff --git a/debian-haskell/Debian/Changes.hs b/debian-haskell/Debian/Changes.hs --- a/debian-haskell/Debian/Changes.hs +++ b/debian-haskell/Debian/Changes.hs @@ -31,14 +31,14 @@ -- |A file generated by dpkg-buildpackage describing the result of a -- package build data ChangesFile = - Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. - , changePackage :: String -- ^ The package name parsed from the .changes file name - , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name - , changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file - , changeArch :: Arch -- ^ The architecture parsed from the .changes file name - , changeInfo :: S.Paragraph' Text -- ^ The contents of the .changes file - , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file - , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute + Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. + , changePackage :: String -- ^ The package name parsed from the .changes file name + , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name + , changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file + , changeArch :: Arch -- ^ The architecture parsed from the .changes file name + , changeInfo :: S.Paragraph' Text -- ^ The contents of the .changes file + , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file + , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute } deriving (Eq, Read, Show) -- |An entry in the list of files generated by the build. @@ -162,7 +162,7 @@ must be preceded by exactly one space. The maintainer details and the date must be separated by exactly two spaces. -The entire changelog must be encoded in UTF-8. +The entire changelog must be encoded in UTF-8. -} -- | Parse the entries of a debian changelog and verify they are all @@ -190,11 +190,11 @@ case matchRegexAll entryRE text of Nothing -> Failure ["Parse error in changelog:\n" ++ show text] Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) -> - Success (Entry name + Success (Entry name (parseDebianVersion version) (map parseReleaseName . words $ dists) urgency - details + details who date, remaining) @@ -208,11 +208,11 @@ case text =~ entryRE :: MatchResult String of x | mrSubList x == [] -> Left ["Parse error in " ++ show text] MR {mrAfter = after, mrSubList = [_, name, ver, dists, urgency, _, details, _, _, who, _, date, _]} -> - Right (Entry name + Right (Entry name (parseDebianVersion ver) (map parseReleaseName . words $ dists) urgency - (" " ++ unpack (strip (pack details)) ++ "\n") + (" " ++ unpack (strip (pack details)) ++ "\n") (take (length who - 2) who) date, after) @@ -254,7 +254,7 @@ (parseDebianVersion ver) (map parseReleaseName . words $ dists) urgency - details + details "" "" MR {mrSubList = x} -> error $ "Unexpected match: " ++ show x where diff --git a/debian-haskell/Debian/Control.hs b/debian-haskell/Debian/Control.hs --- a/debian-haskell/Debian/Control.hs +++ b/debian-haskell/Debian/Control.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- |A module for working with Debian control files -module Debian.Control +module Debian.Control ( -- * Types Control'(..) , Paragraph'(..) diff --git a/debian-haskell/Debian/Control/ByteString.hs b/debian-haskell/Debian/Control/ByteString.hs --- a/debian-haskell/Debian/Control/ByteString.hs +++ b/debian-haskell/Debian/Control/ByteString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} +{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Control.ByteString ( Control'(..) @@ -21,6 +21,10 @@ -- Standard GHC modules +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..)) +#endif +import Control.Applicative (Alternative(..)) import qualified Control.Exception as E import "mtl" Control.Monad.State @@ -89,13 +93,13 @@ else Ok (Comment text, bs') pParagraph :: ControlParser Paragraph -pParagraph = +pParagraph = do f <- pMany1 (pComment <|> pField) pSkipMany (pChar '\n') return (Paragraph f) pControl :: ControlParser Control -pControl = +pControl = do pSkipMany (pChar '\n') c <- pMany pParagraph return (Control c) @@ -104,7 +108,7 @@ -- parseControlFromFile :: FilePath -> IO (Either String Control) instance ControlFunctions C.ByteString where - parseControlFromFile fp = + parseControlFromFile fp = do c <- C.readFile fp case parse pControl c of Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0))) @@ -135,13 +139,13 @@ dropWhileEnd func = LL.reverse . LL.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty protect :: (LL.StringLike a, LL.ListLike a Word8) => a -> a protect l = maybe LL.empty (\ c -> if isHorizSpace c then l else LL.cons (ord' ' ' :: Word8) l) (LL.find (const True :: Word8 -> Bool) l) - isSpace' = isSpace . chr' + -- isSpace' = isSpace . chr' isHorizSpace c = elem c (map ord' " \t") ord' = fromIntegral . ord - chr' = chr . fromIntegral + -- chr' = chr . fromIntegral {- -main = +main = do [fp] <- getArgs C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c) -} @@ -168,13 +172,32 @@ newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) } +instance Functor (Parser state) where + fmap f m = + Parser $ \ state -> + let r = (unParser m) state in + case r of + Ok (a,state') -> Ok (f a,state') + Empty -> Empty + Fail -> Fail + +instance Applicative (Parser state) where + pure = return + (<*>) = ap + +instance Alternative (Parser state) where + empty = + Parser $ \state -> + (unParser mzero) state + (<|>) = mplus + instance Monad (Parser state) where return a = Parser (\s -> Ok (a,s)) m >>= f = Parser $ \state -> let r = (unParser m) state in case r of - Ok (a,state') -> + Ok (a,state') -> case unParser (f a) $ state' of Empty -> Fail o -> o @@ -188,7 +211,7 @@ Empty -> p2 s o -> o ) - + -- Parser (\s -> maybe (p2 s) (Just) (p1 s)) @@ -199,10 +222,6 @@ _pFail = Parser (const Empty) -(<|>) :: Parser state a -> Parser state a -> Parser state a -(<|>) = mplus - - satisfy :: (Char -> Bool) -> Parser C.ByteString Char satisfy f = Parser $ \bs -> @@ -236,14 +255,14 @@ Parser $ \bs -> Ok ((), C.dropWhile p bs) pMany :: Parser st a -> Parser st [a] -pMany p +pMany p = scan id where scan f = do x <- p scan (\tail -> f (x:tail)) <|> return (f []) -notEmpty :: Parser st C.ByteString -> Parser st C.ByteString +notEmpty :: Parser st C.ByteString -> Parser st C.ByteString notEmpty (Parser p) = Parser $ \s -> case p s of o@(Ok (a, _s)) -> @@ -262,7 +281,7 @@ pSkipMany p = scan where scan = (p >> scan) <|> return () - + _pSkipMany1 :: Parser st a -> Parser st () _pSkipMany1 p = p >> pSkipMany p diff --git a/debian-haskell/Debian/Control/Common.hs b/debian-haskell/Debian/Control/Common.hs --- a/debian-haskell/Debian/Control/Common.hs +++ b/debian-haskell/Debian/Control/Common.hs @@ -169,7 +169,7 @@ result <- parseControlFromHandle cmd outh either (return . Left . show) (finish handle) result where - finish handle control = + finish handle control = do exitCode <- waitForProcess handle case exitCode of @@ -185,7 +185,7 @@ md5sumField p = case fieldValue "MD5Sum" p of m@(Just _) -> m - Nothing -> + Nothing -> case fieldValue "Md5Sum" p of m@(Just _) -> m Nothing -> fieldValue "MD5sum" p diff --git a/debian-haskell/Debian/Control/String.hs b/debian-haskell/Debian/Control/String.hs --- a/debian-haskell/Debian/Control/String.hs +++ b/debian-haskell/Debian/Control/String.hs @@ -40,14 +40,14 @@ -- * ControlFunctions instance ControlFunctions String where - parseControlFromFile filepath = - parseFromFile pControl filepath - parseControlFromHandle sourceName handle = + parseControlFromFile filepath = + parseFromFile pControl filepath + parseControlFromHandle sourceName handle = E.try (hGetContents handle) >>= either (\ (e :: E.SomeException) -> error ("parseControlFromHandle String: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) - parseControl sourceName c = + parseControl sourceName c = parse pControl sourceName c - lookupP fieldName (Paragraph paragraph) = + lookupP fieldName (Paragraph paragraph) = find (hasFieldName (map toLower fieldName)) paragraph where hasFieldName name (Field (fieldName',_)) = name == map toLower fieldName' hasFieldName _ _ = False diff --git a/debian-haskell/Debian/Extra/Files.hs b/debian-haskell/Debian/Extra/Files.hs --- a/debian-haskell/Debian/Extra/Files.hs +++ b/debian-haskell/Debian/Extra/Files.hs @@ -9,9 +9,9 @@ import System.IO (hPutStr, hClose, openBinaryTempFile) withTemporaryFile :: MonadIO m - => (FilePath -> m a) -- ^ The function we want to pass a FilePath to - -> String -- ^ The text that the file should contain - -> m a -- ^ The function's return value + => (FilePath -> m a) -- ^ The function we want to pass a FilePath to + -> String -- ^ The text that the file should contain + -> m a -- ^ The function's return value withTemporaryFile f text = do path <- liftIO writeTemporaryFile result <- f path diff --git a/debian-haskell/Debian/GenBuildDeps.hs b/debian-haskell/Debian/GenBuildDeps.hs --- a/debian-haskell/Debian/GenBuildDeps.hs +++ b/debian-haskell/Debian/GenBuildDeps.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} -- |Figure out the dependency relation between debianized source -- directories. The code to actually solve these dependency relations -- for a particular set of binary packages is in Debian.Repo.Dependency. @@ -23,27 +23,29 @@ , getSourceOrder ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif import Control.Exception (throw) -import Control.Monad (filterM) -import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc) -import Data.List +import Control.Monad (filterM) +import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc) +import Data.List import qualified Data.Map as Map -import Data.Maybe +import Data.Maybe import qualified Data.Set as Set import Data.Tree as Tree (Tree(Node, rootLabel, subForest)) -import Debian.Control (parseControlFromFile) -import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) +import Debian.Control (parseControlFromFile) +import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) import Debian.Loc (__LOC__) -import Debian.Relation -import Debian.Relation.Text () -import System.Directory (getDirectoryContents, doesFileExist) +import Debian.Relation +import Debian.Relation.Text () +import System.Directory (getDirectoryContents, doesFileExist) -- | This type describes the build dependencies of a source package. data DepInfo = DepInfo { - sourceName :: SrcPkgName -- ^ source package name - , relations :: Relations -- ^ dependency relations - , binaryNames :: [BinPkgName] -- ^ binary dependency names (is this a function of relations?) + sourceName :: SrcPkgName -- ^ source package name + , relations :: Relations -- ^ dependency relations + , binaryNames :: [BinPkgName] -- ^ binary dependency names (is this a function of relations?) } deriving Show instance Eq DepInfo where diff --git a/debian-haskell/Debian/Relation/ByteString.hs b/debian-haskell/Debian/Relation/ByteString.hs --- a/debian-haskell/Debian/Relation/ByteString.hs +++ b/debian-haskell/Debian/Relation/ByteString.hs @@ -13,7 +13,7 @@ -- * Relation Parser , RelParser , ParseRelations(..) - ) where + ) where import qualified Data.ByteString.Char8 as C diff --git a/debian-haskell/Debian/Relation/Common.hs b/debian-haskell/Debian/Relation/Common.hs --- a/debian-haskell/Debian/Relation/Common.hs +++ b/debian-haskell/Debian/Relation/Common.hs @@ -59,10 +59,10 @@ instance Ord Relation where compare (Rel pkgName1 mVerReq1 _mArch1) (Rel pkgName2 mVerReq2 _mArch2) = - case compare pkgName1 pkgName2 of - LT -> LT - GT -> GT - EQ -> compare mVerReq1 mVerReq2 + case compare pkgName1 pkgName2 of + LT -> LT + GT -> GT + EQ -> compare mVerReq1 mVerReq2 data ArchitectureReq = ArchOnly (Set Arch) diff --git a/debian-haskell/Debian/Relation/String.hs b/debian-haskell/Debian/Relation/String.hs --- a/debian-haskell/Debian/Relation/String.hs +++ b/debian-haskell/Debian/Relation/String.hs @@ -52,7 +52,7 @@ -- are omitted and it is possible to parse relations without them. pRelations :: RelParser Relations pRelations = do -- rel <- sepBy pOrRelation (char ',') - rel <- many pOrRelation + rel <- many pOrRelation eof return rel @@ -92,34 +92,34 @@ pVerReq = do char '<' (do char '<' <|> char ' ' <|> char '\t' - return $ SLT + return $ SLT <|> do char '=' - return $ LTE) + return $ LTE) <|> do string "=" return $ EEQ <|> do char '>' (do char '=' - return $ GRE + return $ GRE <|> do char '>' <|> char ' ' <|> char '\t' - return $ SGR) + return $ SGR) pMaybeArch :: RelParser (Maybe ArchitectureReq) pMaybeArch = do char '[' (do archs <- pArchExcept - char ']' + char ']' skipMany whiteChar - return (Just (ArchExcept (fromList . map parseArchExcept $ archs))) - <|> - do archs <- pArchOnly - char ']' + return (Just (ArchExcept (fromList . map parseArchExcept $ archs))) + <|> + do archs <- pArchOnly + char ']' skipMany whiteChar - return (Just (ArchOnly (fromList . map parseArch $ archs))) - ) + return (Just (ArchOnly (fromList . map parseArch $ archs))) + ) <|> return Nothing diff --git a/debian-haskell/Debian/Relation/Text.hs b/debian-haskell/Debian/Relation/Text.hs --- a/debian-haskell/Debian/Relation/Text.hs +++ b/debian-haskell/Debian/Relation/Text.hs @@ -13,7 +13,7 @@ -- * Relation Parser , RelParser , ParseRelations(..) - ) where + ) where import qualified Data.Text as T diff --git a/debian-haskell/Debian/Report.hs b/debian-haskell/Debian/Report.hs --- a/debian-haskell/Debian/Report.hs +++ b/debian-haskell/Debian/Report.hs @@ -48,7 +48,7 @@ -- see also: |trumpedMap| trumped :: Fetcher -- ^ function for downloading package indexes -> FilePath -- ^ cache directory to store index files in (must already exist) - -> String -- ^ binary architecture + -> String -- ^ binary architecture -> [DebSource] -- ^ sources.list a -> [DebSource] -- ^ sources.list b -> IO (M.Map Text (DebianVersion, DebianVersion)) -- ^ a map of trumped package names to (version a, version b) diff --git a/debian-haskell/Debian/Sources.hs b/debian-haskell/Debian/Sources.hs --- a/debian-haskell/Debian/Sources.hs +++ b/debian-haskell/Debian/Sources.hs @@ -89,7 +89,7 @@ quoteWords' :: String -> [String] quoteWords' [] = [] quoteWords' str = - case break (flip elem " [\"") str of + case break (flip elem (" [\"" :: String)) str of ([],[]) -> [] (w, []) -> [w] (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest)) diff --git a/debian-haskell/Debian/Time.hs b/debian-haskell/Debian/Time.hs --- a/debian-haskell/Debian/Time.hs +++ b/debian-haskell/Debian/Time.hs @@ -1,24 +1,27 @@ +{-# LANGUAGE CPP #-} module Debian.Time where import Data.Time -import Data.Time.Clock.POSIX +#if !MIN_VERSION_time(1,5,0) import System.Locale (defaultTimeLocale) +#endif +import Data.Time.Clock.POSIX import System.Posix.Types -- * Time Helper Functions -rfc822DateFormat :: String -rfc822DateFormat = "%a, %d %b %Y %T %z" +rfc822DateFormat' :: String +rfc822DateFormat' = "%a, %d %b %Y %T %z" epochTimeToUTCTime :: EpochTime -> UTCTime epochTimeToUTCTime = posixSecondsToUTCTime . fromIntegral . fromEnum formatTimeRFC822 :: (FormatTime t) => t -> String -formatTimeRFC822 = formatTime defaultTimeLocale rfc822DateFormat +formatTimeRFC822 = formatTime defaultTimeLocale rfc822DateFormat' parseTimeRFC822 :: (ParseTime t) => String -> Maybe t -parseTimeRFC822 = parseTime defaultTimeLocale rfc822DateFormat +parseTimeRFC822 = parseTime defaultTimeLocale rfc822DateFormat' getCurrentLocalRFC822Time :: IO String -getCurrentLocalRFC822Time = getCurrentTime >>= utcToLocalZonedTime >>= return . formatTime defaultTimeLocale rfc822DateFormat +getCurrentLocalRFC822Time = getCurrentTime >>= utcToLocalZonedTime >>= return . formatTime defaultTimeLocale rfc822DateFormat' diff --git a/debian-haskell/Debian/UTF8.hs b/debian-haskell/Debian/UTF8.hs --- a/debian-haskell/Debian/UTF8.hs +++ b/debian-haskell/Debian/UTF8.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | There are old index files that have funky characters like 'ΓΈ' -- that are not properly UTF8 encoded. As far as I can tell, these -- files are otherwise plain ascii, so just naivelyinsert the @@ -7,7 +8,9 @@ , readFile ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif import qualified Data.ByteString.Char8 as B (concat) import qualified Data.ByteString.Lazy.Char8 as L (ByteString, readFile, toChunks) import Data.Char (chr) diff --git a/debian-haskell/Debian/Util/FakeChanges.hs b/debian-haskell/Debian/Util/FakeChanges.hs --- a/debian-haskell/Debian/Util/FakeChanges.hs +++ b/debian-haskell/Debian/Util/FakeChanges.hs @@ -32,8 +32,8 @@ | VersionMismatch [Maybe String] deriving (Read, Show, Eq, Typeable, Data) -data Files - = Files { dsc :: Maybe (FilePath, Paragraph) +data Files + = Files { dsc :: Maybe (FilePath, Paragraph) , debs :: [(FilePath, Paragraph)] , tar :: Maybe FilePath , diff :: Maybe FilePath @@ -42,12 +42,12 @@ fakeChanges :: [FilePath] -> IO (FilePath, String) fakeChanges fps = do files <- loadFiles fps - let version = getVersion files + let version = getVersion files source = getSource files maintainer = getMaintainer files arches = getArches files binArch = getBinArch files - dist = "unstable" + dist = "unstable" urgency = "low" (invalid, binaries) = unzipEithers $ map (debNameSplit . fst) (debs files) when (not . null $ invalid) (error $ "Some .deb names are invalid: " ++ show invalid) @@ -119,9 +119,9 @@ debSource (deb,p) = case (fieldValue "Source" p) of (Just v) -> v - Nothing -> + Nothing -> case fieldValue "Package" p of - (Just v) -> v + (Just v) -> v Nothing -> error $ "Could not find Source or Package field in " ++ deb @@ -165,7 +165,7 @@ mkFileLine fp | ".deb" `isSuffixOf` fp = do sum <- L.readFile fp >>= return . show . MD5.md5 - size <- liftM fileSize $ getFileStatus fp + size <- liftM fileSize $ getFileStatus fp (Control (p:_)) <- Deb.fields fp return $ concat [ " ", sum, " ", show size, " ", fromMaybe "unknown" (fieldValue "Section" p), " " , fromMaybe "optional" (fieldValue "Priority" p), " ", (takeBaseName fp) @@ -176,7 +176,7 @@ return $ concat [ " ", sum, " ", show size, " ", "unknown", " " , "optional"," ", (takeBaseName fp) ] - + -- more implementations can be found at: -- http://www.google.com/codesearch?hl=en&lr=&q=%22%5BEither+a+b%5D+-%3E+%28%5Ba%5D%2C%5Bb%5D%29%22&btnG=Search unzipEithers :: [Either a b] -> ([a],[b]) @@ -191,8 +191,8 @@ case (takeFileName fp) =~ "^(.*)_(.*)_(.*).deb$" of [[_, name, version, arch]] -> Right (name, version, arch) _ -> Left fp - + loadFiles :: [FilePath] -> IO Files loadFiles files = let (dscs', files'') = partition (isSuffixOf ".dsc") files' @@ -213,7 +213,7 @@ -- if (not . null $ errors) then throwDyn errors else return (debs, listToMaybe dscs, listToMaybe tars, listToMaybe diffs) where loadDsc :: FilePath -> IO (FilePath, Paragraph) - loadDsc dsc' = + loadDsc dsc' = do res <- parseControlFromFile dsc' case res of (Left e) -> error $ "Error parsing " ++ dsc' ++ "\n" ++ show e @@ -229,7 +229,7 @@ getUploader :: IO String getUploader = - do debFullName <- + do debFullName <- do dfn <- try (getEnv "DEBFULLNAME") case dfn of (Right n) -> return n @@ -240,7 +240,7 @@ (Left (_ :: SomeException)) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set." emailAddr <- do eml <- try (getEnv "DEBEMAIL") - case eml of + case eml of (Right e) -> return e (Left (_ :: SomeException)) -> do eml' <- try (getEnv "EMAIL") diff --git a/debian-haskell/Debian/Version.hs b/debian-haskell/Debian/Version.hs --- a/debian-haskell/Debian/Version.hs +++ b/debian-haskell/Debian/Version.hs @@ -1,7 +1,7 @@ -- |A module for parsing, comparing, and (eventually) modifying debian version -- numbers. -module Debian.Version - (DebianVersion -- |Exported abstract because the internal representation is likely to change +module Debian.Version + (DebianVersion -- |Exported abstract because the internal representation is likely to change , prettyDebianVersion , parseDebianVersion , epoch @@ -9,7 +9,7 @@ , revision , buildDebianVersion , evr - ) where + ) where import Debian.Version.Common import Debian.Version.String () diff --git a/debian-haskell/Debian/Version/ByteString.hs b/debian-haskell/Debian/Version/ByteString.hs --- a/debian-haskell/Debian/Version/ByteString.hs +++ b/debian-haskell/Debian/Version/ByteString.hs @@ -9,7 +9,7 @@ import Debian.Version.Common import Debian.Version.Internal - + instance ParseDebianVersion C.ByteString where parseDebianVersion byteStr = let str = C.unpack byteStr in diff --git a/debian-haskell/Debian/Version/Common.hs b/debian-haskell/Debian/Version/Common.hs --- a/debian-haskell/Debian/Version/Common.hs +++ b/debian-haskell/Debian/Version/Common.hs @@ -3,10 +3,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -fno-warn-orphans -fno-warn-unused-do-bind #-} module Debian.Version.Common - ( DebianVersion -- |Exported abstract because the internal representation is likely to change + ( DebianVersion -- |Exported abstract because the internal representation is likely to change , prettyDebianVersion , ParseDebianVersion(..) - , evr -- DebianVersion -> (Maybe Int, String, Maybe String) + , evr -- DebianVersion -> (Maybe Int, String, Maybe String) , epoch , version , revision @@ -106,13 +106,13 @@ showN :: Found Numeric -> String showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn -showN (Simulated _) = "" +showN (Simulated _) = "" -} parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric) parseDV = do skipMany $ oneOf " \t" - e <- parseEpoch + e <- parseEpoch upstreamVersion <- parseNonNumeric True True debianRevision <- option (Simulated (NonNumeric "" (Simulated (Numeric 0 Nothing)))) (char '-' >> parseNonNumeric True False >>= return . Found) return (e, upstreamVersion, debianRevision) @@ -120,8 +120,8 @@ parseEpoch :: CharParser () (Found Int) parseEpoch = option (Simulated 0) (try (many1 digit >>= \d -> char ':' >> return (Found (read d)))) - + parseNonNumeric :: Bool -> Bool -> CharParser () NonNumeric parseNonNumeric zeroOk upstream = do nn <- (if zeroOk then many else many1) ((noneOf "-0123456789") <|> (if upstream then upstreamDash else pzero)) @@ -146,7 +146,7 @@ compareTest str1 str2 = let v1 = either (error . show) id $ parse parseDV str1 str1 v2 = either (error . show) id $ parse parseDV str2 str2 - in + in compare v1 v2 -} @@ -157,7 +157,7 @@ evr (DebianVersion s _) = let re = mkRegex "^(([0-9]+):)?(([^-]*)|((.*)-([^-]*)))$" in -- ( ) ( ( )) - -- ( e ) ( v ) (v2) ( r ) + -- ( e ) ( v ) (v2) ( r ) case matchRegex re s of Just ["", _, _, v, "", _, _] -> (Nothing, v, Nothing) Just ["", _, _, _, _, v, r] -> (Nothing, v, Just r) diff --git a/debian-haskell/Debian/Version/Text.hs b/debian-haskell/Debian/Version/Text.hs --- a/debian-haskell/Debian/Version/Text.hs +++ b/debian-haskell/Debian/Version/Text.hs @@ -9,7 +9,7 @@ import Debian.Version.Common import Debian.Version.Internal - + instance ParseDebianVersion T.Text where parseDebianVersion text = let str = T.unpack text in diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,17 @@ +haskell-cabal-debian (4.24.8) unstable; urgency=low + + * use ghcjs --numeric-ghc-version to set the compilerInfoCompat field + of CompilerInfo. This makes cabal file directives like impl(ghc >= 7.9) + work for ghcjs packages. + + -- David Fox Sun, 29 Mar 2015 12:38:33 -0700 + +haskell-cabal-debian (4.24.7) unstable; urgency=low + + * Remove the Data.Algorithm.Diff modules, they have moved into Diff-0.3.1 + + -- David Fox Tue, 24 Mar 2015 16:51:29 -0700 + haskell-cabal-debian (4.24.6) unstable; urgency=low * Use build dependency haskell-devscripts >= 0.8 for unofficial, >= 0.9 diff --git a/src/Data/Algorithm/Diff/Context.hs b/src/Data/Algorithm/Diff/Context.hs deleted file mode 100644 --- a/src/Data/Algorithm/Diff/Context.hs +++ /dev/null @@ -1,60 +0,0 @@ -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 - -- Predicate satisfied, add x to the current group r and recurse with y at head - groups' (r : rs) (x : y : xs') | f x y = groups' ((x : r) : rs) (y : xs') - -- Predicate not satisfied, add x to current group and start a new group containing y - groups' (r : rs) (x : y : xs') = groups' ([y] : reverse (x : r) : rs) xs' - -- Last element, add it to the current group - groups' (r : rs) [y] = reverse (y : r) : rs - -- Nothing left, return result - groups' rs [] = rs - -- This won't happen, groups' is always called with a non-empty list in the first argument - groups' [] (_ : _) = error "groups" diff --git a/src/Data/Algorithm/Diff/Pretty.hs b/src/Data/Algorithm/Diff/Pretty.hs deleted file mode 100644 --- a/src/Data/Algorithm/Diff/Pretty.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -module Data.Algorithm.Diff.Pretty - ( prettyDiff - , prettyHunk - , prettyChange - ) where - -import Data.Algorithm.Diff (Diff(..)) -import Data.Monoid ((<>)) -import Text.PrettyPrint (Doc, text, empty, hcat) - --- | Pretty print a list of hunks. -prettyDiff :: forall c. Doc -> Doc -> (c -> Doc) -> [[Diff [c]]] -> Doc -prettyDiff _ _ _ [] = empty -prettyDiff old new prettyElem hunks = - hcat . map (<> text "\n") $ (text "--- " <> old : - text "+++ " <> new : - concatMap (prettyHunk prettyElem) hunks) - --- | Pretty print a hunk of adjacent changes -prettyHunk :: (c -> Doc) -> [Diff [c]] -> [Doc] -prettyHunk prettyElem hunk = - text "@@" : concatMap (prettyChange prettyElem) hunk - --- | Pretty print a single change (e.g. a line of a text file) -prettyChange :: (c -> Doc) -> Diff [c] -> [Doc] -prettyChange prettyElem (Both ts _) = map (\ l -> text " " <> prettyElem l) ts -prettyChange prettyElem (First ts) = map (\ l -> text "-" <> prettyElem l) ts -prettyChange prettyElem (Second ts) = map (\ l -> text "+" <> prettyElem l) ts diff --git a/src/Debian/Debianize.hs b/src/Debian/Debianize.hs --- a/src/Debian/Debianize.hs +++ b/src/Debian/Debianize.hs @@ -186,7 +186,7 @@ import Debian.Debianize.InputCabal (inputCabalization) import Debian.Debianize.Monad (CabalM, CabalT, evalCabalM, evalCabalT, execCabalM, execCabalT, runCabalM, runCabalT, DebianT, execDebianT, evalDebianT, liftCabal) import Debian.Debianize.Options (compileArgs) -import Debian.Debianize.Output (compareDebianization, describeDebianization, doDebianizeAction, runDebianizeScript, validateDebianization, writeDebianization) +import Debian.Debianize.Output (compareDebianization, describeDebianization, finishDebianization, runDebianizeScript, validateDebianization, writeDebianization) import Debian.Debianize.Prelude ((%=), (+++=), (++=), (+=), buildDebVersionMap, debOfFile, dpkgFileMap, withCurrentDirectory, (~=), (~?=)) import Debian.Debianize.SourceDebDescription import Debian.Debianize.VersionSplits (DebBase(DebBase)) diff --git a/src/Debian/Debianize/BasicInfo.hs b/src/Debian/Debianize/BasicInfo.hs --- a/src/Debian/Debianize/BasicInfo.hs +++ b/src/Debian/Debianize/BasicInfo.hs @@ -80,7 +80,7 @@ , buildOS :: FilePath -- ^ An environment where we have built a package } deriving (Eq, Ord, Show, Data, Typeable) -data DebAction = Usage | Debianize | SubstVar DebType deriving (Read, Show, Eq, Ord, Data, Typeable) +data DebAction = Usage | Debianize deriving (Read, Show, Eq, Ord, Data, Typeable) -- | A redundant data type, too lazy to expunge. data DebType = Dev | Prof | Doc deriving (Eq, Ord, Read, Show, Data, Typeable) @@ -124,12 +124,6 @@ , "Distribution.PackageDescription.Configuration when loading the cabal file."]), Option "" ["debianize"] (NoArg (debAction ~= Debianize)) "Deprecated - formerly used to get what is now the normal benavior.", - Option "" ["substvar"] (ReqArg (\ name -> debAction ~= (SubstVar (read' (\ s -> error $ "substvar: " ++ show s) name))) "Doc, Prof, or Dev") - (unlines [ "With this option no debianization is generated. Instead, the list" - , "of dependencies required for the dev, prof or doc package (depending" - , "on the argument) is printed to standard output. These can be added" - , "to the appropriate substvars file. (This is an option whose use case" - , "is lost in the mists of time.)"]), Option "" ["buildenvdir"] (ReqArg (\ s -> buildEnv ~= EnvSet {cleanOS = s "clean", dependOS = s "depend", buildOS = s "build"}) "PATH") "Directory containing the three build environments, clean, depend, and build.", Option "f" ["cabal-flags"] (ReqArg (\ s -> cabalFlagAssignments %= (Set.union (fromList (flagList s)))) "FLAG FLAG ...") diff --git a/src/Debian/Debianize/Bundled.hs b/src/Debian/Debianize/Bundled.hs --- a/src/Debian/Debianize/Bundled.hs +++ b/src/Debian/Debianize/Bundled.hs @@ -1,7 +1,7 @@ -- | Determine whether a specific version of a Haskell package is -- bundled with into this particular version of the given compiler. -{-# LANGUAGE CPP, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} module Debian.Debianize.Bundled ( builtIn -- * Utilities diff --git a/src/Debian/Debianize/CabalInfo.hs b/src/Debian/Debianize/CabalInfo.hs --- a/src/Debian/Debianize/CabalInfo.hs +++ b/src/Debian/Debianize/CabalInfo.hs @@ -17,31 +17,27 @@ , newCabalInfo ) where -import OldLens (access) - import Control.Category ((.)) import Control.Lens.TH (makeLenses) -import Control.Monad (unless, when) import Control.Monad.State (execStateT) import Control.Monad.Trans (liftIO) import Data.Generics (Data, Typeable) -import Data.List as List (null) import Data.Map as Map (Map) import Data.Monoid (Monoid(..)) import Data.Text as Text (null, pack, strip) import Debian.Debianize.BasicInfo (Flags) -import Debian.Debianize.DebInfo as D (control, copyright, DebInfo, makeDebInfo, enableTests, runTests, rulesSettings) +import Debian.Debianize.DebInfo as D (control, copyright, DebInfo, makeDebInfo) import Debian.Debianize.BinaryDebDescription (Canonical(canonical)) import Debian.Debianize.CopyrightDescription (defaultCopyrightDescription) import Debian.Debianize.InputCabal (inputCabalization) -import Debian.Debianize.Prelude ((~=), (%=)) +import Debian.Debianize.Prelude ((~=)) import Debian.Debianize.SourceDebDescription as S (homepage) import Debian.Debianize.VersionSplits (VersionSplits) import Debian.Orphans () import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion) import Distribution.Package (PackageName) -import Distribution.PackageDescription as Cabal (PackageDescription(homepage, testSuites)) +import Distribution.PackageDescription as Cabal (PackageDescription(homepage)) import Prelude hiding ((.), init, init, log, log, null) -- This enormous record is a mistake - instead it should be an Atom diff --git a/src/Debian/Debianize/Files.hs b/src/Debian/Debianize/Files.hs --- a/src/Debian/Debianize/Files.hs +++ b/src/Debian/Debianize/Files.hs @@ -1,6 +1,6 @@ -- | Convert a Debianization into a list of files that can then be -- written out. -{-# LANGUAGE CPP, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Debian.Debianize.Files ( debianizationFileMap diff --git a/src/Debian/Debianize/InputCabal.hs b/src/Debian/Debianize/InputCabal.hs --- a/src/Debian/Debianize/InputCabal.hs +++ b/src/Debian/Debianize/InputCabal.hs @@ -12,7 +12,11 @@ import Data.Set as Set (Set, toList) import Debian.Debianize.BasicInfo (Flags, buildEnv, dependOS, verbosity, compilerFlavor, cabalFlagAssignments) import Debian.Debianize.Prelude (intToVerbosity') +#if MIN_VERSION_Cabal(1,22,0) +import Debian.GHC (getCompilerInfo) +#else import Debian.GHC (newestAvailableCompilerId) +#endif import Debian.Orphans () #if MIN_VERSION_Cabal(1,22,0) import Distribution.Compiler (AbiTag(NoAbiTag), unknownCompilerInfo) @@ -39,30 +43,26 @@ inputCabalization :: Flags -> IO PackageDescription inputCabalization flags = do let root = dependOS $ getL buildEnv flags - let cid = newestAvailableCompilerId root (getL compilerFlavor flags) - ePkgDesc <- inputCabalization' (intToVerbosity' $ getL verbosity flags) (getL cabalFlagAssignments flags) cid + let vb = intToVerbosity' $ getL verbosity flags + fs = getL cabalFlagAssignments flags + -- Load a GenericPackageDescription from the current directory and + -- from that create a finalized PackageDescription for the given + -- CompilerId. + genPkgDesc <- defaultPackageDesc vb >>= readPackageDescription vb +#if MIN_VERSION_Cabal(1,22,0) + cinfo <- getCompilerInfo root (getL compilerFlavor flags) +#else + let cinfo = newestAvailableCompilerId root (getL compilerFlavor flags) +#endif + let finalized = finalizePackageDescription (toList fs) (const True) (Platform buildArch Cabal.buildOS) cinfo [] genPkgDesc + ePkgDesc <- either (return . Left) + (\ (pkgDesc, _) -> do bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc + return (Right pkgDesc)) + finalized either (\ deps -> getCurrentDirectory >>= \ here -> error $ "Missing dependencies in cabal package at " ++ here ++ ": " ++ show deps) return ePkgDesc - --- | Load a GenericPackageDescription from the current directory and --- from that create a finalized PackageDescription for the given --- CompilerId. -inputCabalization' :: Verbosity -> Set (FlagName, Bool) -> CompilerId -> IO (Either [Dependency] PackageDescription) -inputCabalization' vb flags cid = do - genPkgDesc <- defaultPackageDesc vb >>= readPackageDescription vb - let cid' = -#if MIN_VERSION_Cabal(1,22,0) - unknownCompilerInfo cid NoAbiTag -#else - cid -#endif - let finalized = finalizePackageDescription (toList flags) (const True) (Platform buildArch Cabal.buildOS) cid' [] genPkgDesc - either (return . Left) - (\ (pkgDesc, _) -> do bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc - return (Right pkgDesc)) - finalized -- | Run the package's configuration script. autoreconf :: Verbosity -> Cabal.PackageDescription -> IO () diff --git a/src/Debian/Debianize/InputDebian.hs b/src/Debian/Debianize/InputDebian.hs --- a/src/Debian/Debianize/InputDebian.hs +++ b/src/Debian/Debianize/InputDebian.hs @@ -1,5 +1,5 @@ -- | Read an existing Debianization from a directory file. -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.Debianize.InputDebian ( inputDebianization @@ -203,7 +203,7 @@ inputCabalInfo _ path | elem path ["control"] = return () inputCabalInfo debian name@"source/format" = liftIO (readFile (debian name)) >>= \ text -> either (warning +=) ((sourceFormat ~=) . Just) (readSourceFormat text) inputCabalInfo debian name@"watch" = liftIO (readFile (debian name)) >>= \ text -> watch ~= Just text -inputCabalInfo debian name@"rules" = liftIO (readFile (debian name)) >>= \ text -> rulesHead ~= (Just $ strip text <> "\n") +inputCabalInfo debian name@"rules" = liftIO (readFile (debian name)) >>= \ text -> rulesHead ~= (Just $ strip text <> pack "\n") inputCabalInfo debian name@"compat" = liftIO (readFile (debian name)) >>= \ text -> compat ~= Just (read' (\ s -> error $ "compat: " ++ show s) (unpack text)) inputCabalInfo debian name@"copyright" = liftIO (readFile (debian name)) >>= \ text -> copyright ~= Just (readCopyrightDescription text) inputCabalInfo debian name@"changelog" = diff --git a/src/Debian/Debianize/Options.hs b/src/Debian/Debianize/Options.hs --- a/src/Debian/Debianize/Options.hs +++ b/src/Debian/Debianize/Options.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RankNTypes #-} +{-# LANGUAGE FlexibleContexts, RankNTypes #-} module Debian.Debianize.Options ( options , compileArgs diff --git a/src/Debian/Debianize/Output.hs b/src/Debian/Debianize/Output.hs --- a/src/Debian/Debianize/Output.hs +++ b/src/Debian/Debianize/Output.hs @@ -6,7 +6,7 @@ {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Debianize.Output - ( doDebianizeAction + ( finishDebianization , runDebianizeScript , writeDebianization , describeDebianization @@ -18,26 +18,30 @@ import Control.Category ((.)) import Control.Exception as E (throw) -import Control.Monad.State (get) +import Control.Lens (zoom) +import Control.Monad.State (get, StateT) import Control.Monad.Trans (liftIO, MonadIO) -import Data.Algorithm.Diff.Context (contextDiff) -import Data.Algorithm.Diff.Pretty (prettyDiff) +import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) +import Data.List (unlines) import Data.Map as Map (elems, toList) import Data.Maybe (fromMaybe) import Data.Text as Text (split, Text, unpack) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) -import Debian.Debianize.BasicInfo (dryRun, validate) +import Debian.Debianize.BasicInfo (DebAction(Usage), debAction, dryRun, validate) +import Debian.Debianize.CabalInfo (CabalInfo, debInfo) import qualified Debian.Debianize.DebInfo as D import Debian.Debianize.Files (debianizationFileMap) import Debian.Debianize.InputDebian (inputDebianization) import Debian.Debianize.Monad (DebianT, evalDebianT) -import Debian.Debianize.Options (putEnvironmentArgs) +import Debian.Debianize.Options (options, putEnvironmentArgs) import Debian.Debianize.Prelude (indent, replaceFile, zipMaps) import Debian.Debianize.BinaryDebDescription as B (canonical, package) import qualified Debian.Debianize.SourceDebDescription as S import Debian.Pretty (ppShow, ppPrint) import Prelude hiding ((.), unlines, writeFile) +import System.Console.GetOpt (OptDescr, usageInfo) import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions) +import System.Environment (getProgName) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((), takeDirectory) import System.IO (hPutStrLn, stderr) @@ -70,10 +74,13 @@ -- | Depending on the options in @atoms@, either validate, describe, -- or write the generated debianization. -doDebianizeAction :: (MonadIO m, Functor m) => DebianT m () -doDebianizeAction = +finishDebianization :: forall m. (MonadIO m, Functor m) => StateT CabalInfo m () +finishDebianization = zoom debInfo $ do new <- get case () of + _ | getL (D.flags . debAction) new == Usage -> + do progName <- liftIO getProgName + liftIO $ putStrLn (usageInfo (usageHeader progName) (options :: [OptDescr (StateT CabalInfo m ())])) _ | getL (D.flags . validate) new -> do inputDebianization old <- get @@ -84,6 +91,19 @@ diff <- liftIO $ compareDebianization old new liftIO $ putStr ("Debianization (dry run):\n" ++ diff) _ -> writeDebianization + where + usageHeader progName = + unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: " + , "" + , " " ++ progName ++ " --maintainer 'Maintainer Name '." + , "" + , "This will read the package's cabal file and any existing debian/changelog file and" + , "deduce what it can about the debianization, then it will create or modify files in" + , "the debian subdirectory. Note that it will not remove any files in debian, and" + , "these could affect the operation of the debianization in unknown ways. For this" + , "reason I recommend either using a pristine unpacked directory each time, or else" + , "using a revision control system to revert the package to a known state before running." + , "The following additional options are available:" ] -- | Write the files of the debianization @d@ to ./debian writeDebianization :: (MonadIO m, Functor m) => DebianT m () @@ -116,7 +136,7 @@ doFile path (Just o) (Just n) = if o == n then Nothing -- Just (path ++ ": Unchanged\n") - else Just (show (prettyDiff (text ("old" path)) (text ("new" path)) (text . unpack) (contextDiff 2 (split (== '\n') o) (split (== '\n') n)))) + else Just (show (prettyContextDiff (text ("old" path)) (text ("new" path)) (text . unpack) (getContextDiff 2 (split (== '\n') o) (split (== '\n') n)))) doFile _path Nothing Nothing = error "Internal error in zipMaps" -- | Make sure the new debianization matches the existing diff --git a/src/Debian/Debianize/SubstVars.hs b/src/Debian/Debianize/SubstVars.hs deleted file mode 100644 --- a/src/Debian/Debianize/SubstVars.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# 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 OldLens (access, getL, modL) - -import Control.Category ((.)) -import Control.Exception (SomeException, try) -import Control.Monad (foldM) -import Control.Monad.Reader (ReaderT(runReaderT)) -import Control.Monad.State (get) -import Control.Monad.Trans (lift, liftIO, MonadIO) -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, unlines) -import Data.List as List (map) -import qualified Data.Map as Map (insert, lookup, Map) -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) -import qualified Data.Set as Set (member, Set) -import Data.Text (pack) -import Debian.Control (Control'(unControl), ControlFunctions(lookupP, parseControl, stripWS), Field'(Field)) -import Debian.Debianize.BasicInfo (DebType(..), dryRun) -import qualified Debian.Debianize.DebInfo as D (flags, extraLibMap, missingDependencies) -import Debian.Debianize.Monad (CabalT) -import Debian.Debianize.Prelude ((!), buildDebVersionMap, cond, DebMap, debOfFile, diffFile, dpkgFileMap, modifyM, replaceFile, showDeps) -import qualified Debian.Debianize.CabalInfo as A (CabalInfo, debInfo, packageDescription, packageInfo, PackageInfo(PackageInfo, cabalName, devDeb, docDeb, profDeb)) -import Debian.Orphans () -import Debian.Pretty (ppShow) -import Debian.Relation (BinPkgName(BinPkgName), Relation, Relations) -import qualified Debian.Relation as D (BinPkgName(BinPkgName), ParseRelations(parseRelations), Relation(Rel), Relations, VersionReq(GRE)) -import Distribution.Compiler (buildCompilerId) -import Distribution.Package (Dependency(..), PackageName(PackageName)) -import Distribution.PackageDescription as Cabal (allBuildInfo, buildTools, extraLibs, PackageDescription(..), pkgconfigDepends) -import Distribution.Simple.Utils (die) -import Distribution.Text (display) -import Prelude hiding ((.), unlines) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) - --- | Expand the contents of the .substvars file for a library package. --- Each cabal package corresponds to a directory -, --- 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-.a and libHS-_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 :: (MonadIO m, Functor m) => - DebType -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc - -> CabalT m () -substvars debType = - do debVersions <- liftIO buildDebVersionMap - modifyM (liftIO . libPaths debVersions) - control <- liftIO $ readFile "debian/control" >>= either (error . show) return . parseControl "debian/control" - substvars' debType control - -substvars' :: (MonadIO m, Functor m) => DebType -> Control' String -> CabalT m () -substvars' debType control = - get >>= return . getL A.packageInfo >>= \ info -> - cabalDependencies >>= \ cabalDeps -> - case (missingBuildDeps info cabalDeps, 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 <- liftIO $ readFile path' - deps <- debDeps debType control - new <- addDeps old deps - dry <- get >>= return . getL (A.debInfo . D.flags . dryRun) - liftIO (diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path')) - (\ diff -> if dry then putStr diff else replaceFile path' new)) - ([], Nothing) -> return () - (missing, _) -> - liftIO $ die ("These debian packages need to be added to the build dependency list so the required cabal " ++ - "packages are available:\n " ++ intercalate "\n " (map (ppShow . 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 deps = - case partition (isPrefixOf "haskell:Depends=") (lines old) of - ([], other) -> filterMissing deps >>= \ deps' -> return $ unlines (("haskell:Depends=" ++ showDeps deps') : other) - (hdeps, more) -> - case deps of - [] -> return $ unlines (hdeps ++ more) - _ -> filterMissing deps >>= \ deps' -> return $ unlines (map (++ (", " ++ showDeps deps')) hdeps ++ more) - path = fmap (\ (D.BinPkgName x) -> "debian/" ++ x ++ ".substvars") name - name = debNameFromType control debType - -- We must have build dependencies on the profiling and documentation packages - -- of all the cabal packages. - missingBuildDeps info cabalDeps = - let requiredDebs = - concat (map (\ (Dependency name _) -> - case Map.lookup name info of - Just info' -> - let prof = maybe (A.devDeb info') Just (A.profDeb info') in - let doc = A.docDeb info' in - catMaybes [prof, doc] - Nothing -> []) cabalDeps) 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 :: DebMap -> A.CabalInfo -> IO A.CabalInfo -libPaths debVersions atoms = - do a <- getDirPaths "/usr/lib" - b <- getDirPaths ("/usr/lib/haskell-packages" display buildCompilerId "lib") - -- Build a map from names of installed debs to version numbers - dpkgFileMap >>= runReaderT (foldM (packageInfo' debVersions) atoms (a ++ b)) - where - getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id - -packageInfo' :: DebMap -> A.CabalInfo -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO A.CabalInfo -packageInfo' 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 buildCompilerId - 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 A.packageInfo (Map.insert - (PackageName p) - (A.PackageInfo { A.cabalName = PackageName p - , A.devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev - , A.profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof - , A.docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) atoms - -data Dependency_ - = BuildDepends Dependency - | BuildTools Dependency - | PkgConfigDepends Dependency - | ExtraLibs Relations - 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 - --- Make a list of the debian devel packages corresponding to cabal packages --- which are build dependencies -debDeps :: (MonadIO m, Functor m) => DebType -> Control' String -> CabalT m D.Relations -debDeps debType control = - do info <- get >>= return . getL A.packageInfo - cabalDeps <- cabalDependencies - return $ interdependencies ++ otherdependencies info cabalDeps - where - interdependencies = - case debType of - Prof -> maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) (debNameFromType control Dev) - _ -> [] - otherdependencies info cabalDeps = - catMaybes (map (\ (Dependency name _) -> - case Map.lookup name info of - Just p -> maybe Nothing - (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) - (case debType of - Dev -> A.devDeb p - Prof -> A.profDeb p - Doc -> A.docDeb p) - Nothing -> Nothing) cabalDeps) - -cabalDependencies :: (MonadIO m, Functor m) => CabalT m [Dependency] -cabalDependencies = - do pkgDesc <- access A.packageDescription - atoms <- get - return $ catMaybes $ map unboxDependency $ - allBuildDepends atoms - (Cabal.buildDepends pkgDesc) - (concatMap buildTools . allBuildInfo $ pkgDesc) - (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) - (concatMap extraLibs . allBuildInfo $ pkgDesc) - --- |Debian packages don't have per binary package build dependencies, --- so we just gather them all up here. -allBuildDepends :: A.CabalInfo -> [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] -> [Relations] - fixDeps xs = map (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]] - (Map.lookup cab (getL (A.debInfo . D.extraLibMap) atoms))) xs - --- | 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)))) - -filterMissing :: Monad m => [[Relation]] -> CabalT m [[Relation]] -filterMissing rels = - do missing <- get >>= return . getL (A.debInfo . D.missingDependencies) - return $ filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name missing))) rels) diff --git a/src/Debian/GHC.hs b/src/Debian/GHC.hs --- a/src/Debian/GHC.hs +++ b/src/Debian/GHC.hs @@ -10,6 +10,9 @@ -- , ghcNewestAvailableVersion -- , compilerIdFromDebianVersion , compilerPackageName +#if MIN_VERSION_Cabal(1,22,0) + , getCompilerInfo +#endif ) where import Control.DeepSeq (force) @@ -18,16 +21,21 @@ import Data.Char ({-isSpace, toLower,-} toUpper) import Data.Function.Memoize (deriveMemoizable, memoize2) import Data.Maybe (fromMaybe) -import Data.Version (showVersion, Version(Version)) +import Data.Version (showVersion, Version(Version), parseVersion) import Debian.Debianize.BinaryDebDescription (PackageType(..)) import Debian.Relation (BinPkgName(BinPkgName)) import Debian.Version (DebianVersion, parseDebianVersion) import Distribution.Compiler (CompilerFlavor(..), CompilerId(CompilerId)) +#if MIN_VERSION_Cabal(1,22,0) +import Distribution.Compiler (CompilerInfo(..), unknownCompilerInfo, AbiTag(NoAbiTag)) +#endif import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..)) import System.Directory (doesDirectoryExist) +import System.Exit (ExitCode(ExitFailure)) import System.IO.Unsafe (unsafePerformIO) -import System.Process (readProcess) -import System.Unix.Chroot (useEnv) +import System.Process (readProcess, showCommandForUser, readProcessWithExitCode) +import System.Unix.Chroot (useEnv, fchroot) +import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) $(deriveMemoizable ''CompilerFlavor) @@ -145,3 +153,40 @@ compilerPackageName GHCJS _ = BinPkgName "ghcjs" -- whatevs #endif compilerPackageName x _ = error $ "Unsupported compiler flavor: " ++ show x + +#if MIN_VERSION_Cabal(1,22,0) +-- | IO based alternative to newestAvailableCompilerId - install the +-- compiler into the chroot if necessary and ask it for its version +-- number. This has the benefit of working for ghcjs, which doesn't +-- make the base ghc version available in the version number. +-- +-- Assumes the compiler executable is already installed in the root +-- environment. +getCompilerInfo :: FilePath -> CompilerFlavor -> IO CompilerInfo +getCompilerInfo "/" flavor = do +{- + (code, _, _) <- readProcessWithExitCode "apt-get" ["install", compilerDebName] "" + case code of + ExitFailure n -> error $ "Failure " ++ show n ++ " installing compiler flavor " ++ show flavor + _ -> return () +-} + compilerId <- runVersionCommand >>= toCompilerId flavor + compilerCompat <- case flavor of + GHCJS -> readProcessWithExitCode "ghcjs" ["--numeric-ghc-version"] "" >>= toCompilerId GHC >>= return . Just . (: []) + _ -> return Nothing + return $ (unknownCompilerInfo compilerId NoAbiTag) {compilerInfoCompat = compilerCompat} + where + runVersionCommand :: IO (ExitCode, String, String) + runVersionCommand = readProcessWithExitCode versionCommand ["--numeric-version"] "" + versionCommand = case flavor of GHC -> "ghc"; GHCJS -> "ghcjs"; _ -> error $ "Flavor " ++ show flavor + + toCompilerId :: CompilerFlavor -> (ExitCode, String, String) -> IO CompilerId + toCompilerId _ (ExitFailure n, _, err) = + error $ showCommandForUser versionCommand ["--numeric-version"] ++ " -> " ++ show n ++ ", stderr: " ++ show err + toCompilerId flavor' (_, out, _) = + case filter ((== "\n") . snd) (readP_to_S parseVersion out) of + [(v, _)] -> return $ CompilerId flavor' v + _ -> error $ "Parse failure for version string: " ++ show out + +getCompilerInfo root flavor = fchroot root $ getCompilerInfo "/" flavor +#endif