diff --git a/Debian/Apt/Index.hs b/Debian/Apt/Index.hs --- a/Debian/Apt/Index.hs +++ b/Debian/Apt/Index.hs @@ -32,7 +32,6 @@ import Debian.Control.ByteString import Debian.Control.Common import Debian.Control.Text (decodeControl) -import Debian.Pretty (PP(..)) import Debian.Release import Debian.Sources import Debian.URI @@ -125,7 +124,7 @@ where baseURI = sourceUri debSource (release, sections) = - either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint (PP debSource))) id (sourceDist debSource) + either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint debSource)) id (sourceDist debSource) -- |return a tuple for the section -- - the URI to the uncompressed index file diff --git a/Debian/Control/Common.hs b/Debian/Control/Common.hs --- a/Debian/Control/Common.hs +++ b/Debian/Control/Common.hs @@ -97,13 +97,13 @@ -- | This may have bad performance issues (dsf: Whoever wrote this -- comment should have explained why.) -instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Control' a)) where - pPrint = ppControl . unPP -instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Paragraph' a)) where - pPrint = ppParagraph . unPP +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Control' a) where + pPrint = ppControl +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Paragraph' a) where + pPrint = ppParagraph -instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Field' a)) where - pPrint = ppField . unPP +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Field' a) where + pPrint = ppField ppControl :: (ControlFunctions a, Pretty (PP a)) => Control' a -> Doc ppControl (Control paragraph) = diff --git a/Debian/Control/Policy.hs b/Debian/Control/Policy.hs --- a/Debian/Control/Policy.hs +++ b/Debian/Control/Policy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} -- | Access to things that Debian policy says should be in a valid -- control file. The pure functions will not throw ControlFileError @@ -29,16 +29,18 @@ import Control.Exception (Exception, throw) import Control.Monad.Catch (MonadCatch, try) +import Data.List (intercalate) import Data.Text (Text) import Data.Typeable (Typeable) import Data.ListLike (toList) import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl)) import Debian.Control.Text () import Debian.Loc (__LOC__) -import Debian.Pretty (ppDisplay) +import Debian.Pretty (prettyShow) import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations) import Debian.Relation.Text () -import Language.Haskell.TH (Loc) +import Language.Haskell.TH (Loc(..)) +import Prelude hiding (ioError) -- import qualified Debug.ShowPlease as Please import Text.Parsec.Error (ParseError) @@ -47,7 +49,7 @@ data DebianControl = DebianControl {unDebianControl :: Control' Text} instance Show DebianControl where - show c = "(parseDebianControl \"\" " ++ show (ppDisplay (unDebianControl c)) ++ ")" + show c = "(parseDebianControl \"\" " ++ show (prettyShow (unDebianControl c)) ++ ")" -- | Validate and return a control file in an opaque wrapper. May -- throw a ControlFileError. Currently we only verify that it has a @@ -99,7 +101,18 @@ | ParseRelationsError {locs :: [Loc], parseError :: ParseError} | ParseControlError {locs :: [Loc], parseError :: ParseError} | IOError {locs :: [Loc], ioError :: IOError} - deriving (Show, Typeable) + deriving Typeable + +instance Show ControlFileError where + show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs" + show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs" + show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field + show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError + show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError + show (IOError {..}) = intercalate ", " (map showLoc locs) ++ ": IOError " ++ show ioError + +showLoc :: Loc -> String +showLoc x = show (loc_filename x) ++ "(line " ++ show (fst (loc_start x)) ++ ", column " ++ show (snd (loc_start x)) ++ ")" -- instance Please.Show ControlFileError where -- show (IOError e) = "(IOError " ++ Please.show e ++ ")" diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs --- a/Debian/GenBuildDeps.hs +++ b/Debian/GenBuildDeps.hs @@ -2,14 +2,15 @@ -- |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. -module Debian.GenBuildDeps +module Debian.GenBuildDeps ( DepInfo(..) + , sourceName' + , relations' + , binaryNames' -- * Preparing dependency info , buildDependencies , RelaxInfo , relaxDeps - , OldRelaxInfo(..) - , oldRelaxDeps -- * Using dependency info , BuildableInfo(..) , ReadyTarget(..) @@ -25,17 +26,17 @@ import Control.Applicative ((<$>)) import Control.Exception (throw) import Control.Monad (filterM) -import Data.Graph (Graph, Edge, buildG, topSort, reachable, transposeG, vertices, edges) +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 qualified Data.Set as Set +import Data.Tree as Tree (Tree(Node, rootLabel, subForest)) import Debian.Control (parseControlFromFile) -import Debian.Control.Policy (HasDebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) +import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) import Debian.Loc (__LOC__) import Debian.Relation import Debian.Relation.Text () -import Language.Haskell.TH (Loc) import System.Directory (getDirectoryContents, doesFileExist) -- | This type describes the build dependencies of a source package. @@ -43,8 +44,13 @@ 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 + a == b = (sourceName a == sourceName b) && + Set.fromList (map Set.fromList (relations a)) == Set.fromList (map Set.fromList (relations b)) && + Set.fromList (binaryNames a) == Set.fromList (binaryNames b) + -- |Return the dependency info for a source package with the given dependency relaxation. -- |According to debian policy, only the first paragraph in debian\/control can be a source package -- @@ -55,6 +61,19 @@ fromMaybe [] (debianBuildDepsIndep control)] , binaryNames = debianBinaryPackageNames control } +-- | source package name +sourceName' :: HasDebianControl control => control -> SrcPkgName +sourceName' control = debianSourcePackageName control + +-- | dependency relations +relations' :: HasDebianControl control => control -> Relations +relations' control = concat [fromMaybe [] (debianBuildDeps control), + fromMaybe [] (debianBuildDepsIndep control)] + +-- | binary dependency names (is this a function of relations?) +binaryNames' :: HasDebianControl control => control -> [BinPkgName] +binaryNames' control = debianBinaryPackageNames control + -- |Specifies build dependencies that should be ignored during the build -- decision. If the pair is (BINARY, Nothing) it means the binary package -- BINARY should always be ignored when deciding whether to build. If the @@ -70,16 +89,6 @@ -- OldRelaxInfo.) type RelaxInfo = SrcPkgName -> BinPkgName -> Bool -_makeRelaxInfo :: OldRelaxInfo -> RelaxInfo -_makeRelaxInfo (RelaxInfo xs) srcPkgName binPkgName = - Set.member binPkgName global || maybe False (Set.member binPkgName) (Map.lookup srcPkgName mp) - where - (global :: Set.Set BinPkgName, mp :: Map.Map SrcPkgName (Set.Set BinPkgName)) = - foldr (\ entry (global', mp') -> - case entry of - (b, Just s) -> (global', Map.insertWith Set.union s (Set.singleton b) mp') - (b, Nothing) -> (Set.insert b global', mp')) (Set.empty, Map.empty) xs - -- |Remove any dependencies that are designated \"relaxed\" by relaxInfo. relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo] relaxDeps relaxInfo deps = @@ -96,31 +105,6 @@ keepDep :: Relation -> Bool keepDep (Rel name _ _) = not (relaxInfo (sourceName info) name) --- |Remove any dependencies that are designated \"relaxed\" by relaxInfo. -oldRelaxDeps :: OldRelaxInfo -> [DepInfo] -> [DepInfo] -oldRelaxDeps relaxInfo deps = - map relaxDep deps - where - relaxDep :: DepInfo -> DepInfo - relaxDep info = info {relations = filteredDependencies} - where - -- Discard any dependencies not on the filtered package name list. If - -- this results in an empty list in an or-dep the entire dependency can - -- be discarded. - filteredDependencies :: Relations - filteredDependencies = filter (/= []) (map (filter keepDep) (relations info)) - keepDep :: Relation -> Bool - keepDep (Rel name _ _) = not (elem name ignored) - -- Binary packages to be ignored wrt this source package's build decision - ignored = ignoredForSourcePackage (sourceName info) relaxInfo - -- Return a list of binary packages which should be ignored for this - -- source package. - ignoredForSourcePackage :: SrcPkgName -> OldRelaxInfo -> [BinPkgName] - ignoredForSourcePackage source (RelaxInfo pairs) = - map fst . filter (maybe True (== source) . snd) $ pairs - -- concat . map binaries . catMaybes . map snd . filter (\ (_, x) -> maybe True (== source) x) $ pairs - --- | data ReadyTarget a = ReadyTarget { ready :: a -- ^ Some target whose build dependencies are all satisfied @@ -141,20 +125,21 @@ -- list of packages, return a ReadyTarget triple: One ready package, -- the packages that depend on the ready package directly or -- indirectly, and all the other packages. -buildable :: (a -> a -> Ordering) -> [a] -> BuildableInfo a -buildable cmp packages = +buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a +buildable relax packages = -- Find all packages which can't reach any other packages in the -- graph of the "has build dependency" relation. case partition (\ x -> reachable hasDep x == [x]) verts of -- None of the packages are buildable, return information -- about how to break this build dependency cycle. - ([], _) -> CycleInfo {depPairs = map ofEdge (cycleEdges hasDep)} + ([], _) -> CycleInfo {depPairs = map ofEdge $ head $ (allCycles hasDep)} -- We have some buildable packages, return them along with -- the list of packages each one directly blocks (allReady, blocked) -> BuildableInfo { readyTargets = map (makeReady blocked allReady) allReady , allBlocked = map ofVertex blocked } where + makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a makeReady blocked ready thisReady = let otherReady = filter (/= thisReady) ready (directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in @@ -162,37 +147,57 @@ , waiting = map ofVertex directlyBlocked , other = map ofVertex (otherReady ++ otherBlocked) } --allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x))) - isDep = buildG (0, length packages - 1) edges' - edges' = map (\ (a, b) -> (b, a)) edges'' - hasDep = buildG (0, length packages - 1) edges'' - edges'' :: [(Int, Int)] - edges'' = + isDep :: Graph + isDep = transposeG hasDep + hasDep :: Graph + hasDep = buildG (0, length packages - 1) hasDepEdges + + hasDepEdges :: [(Int, Int)] + hasDepEdges = nub (foldr f [] (tails vertPairs)) - where f [] es = es + where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)] + f [] es = es f (x : xs) es = catMaybes (map (toEdge x) xs) ++ es + toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge toEdge (xv, xa) (yv, ya) = - case cmp xa ya of + case compareSource xa ya of EQ -> Nothing LT -> Just (yv, xv) GT -> Just (xv, yv) + ofEdge :: Edge -> (a, a) ofEdge (a, b) = (ofVertex a, ofVertex b) + ofVertex :: Int -> a ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages)))) verts :: [Int] verts = map fst vertPairs - vertPairs = zip [0..] packages + vertPairs :: [(Int, DepInfo)] + vertPairs = zip [0..] $ map relax packages -cycleEdges :: Graph -> [Edge] -cycleEdges g = - filter (`elem` (edges g)) - (Set.toList (Set.intersection - (Set.fromList (closure g)) - (Set.fromList (closure (transposeG g))))) +-- | Find a cycle in a graph that involves +allCycles :: Graph -> [[Edge]] +allCycles g = + -- Every cycle is confined to an SCC (strongly connected component). + -- Every node in an SCC is part of some cycle. + concatMap sccCycles (scc g) where - closure g' = concat (map (\ v -> (map (\ u -> (v, u)) (reachable g' v))) (vertices g')) - --self (a, b) = a == b - --distrib = concat . map (\ (n, ms) -> map (\ m -> (n, m)) ms) - --swap (a, b) = (b, a) + -- Find all the cycles in an SCC + sccCycles :: Tree Vertex -> [[Edge]] + sccCycles t = mapMaybe addBackEdge (treePaths t) + addBackEdge :: [Vertex] -> Maybe [Edge] + addBackEdge path@(root : _) = + let back = (last path, root) in + if elem back (edges g) then Just (pathEdges (path ++ [root])) else Nothing + +-- | All the paths from root to a leaf +treePaths :: Tree a -> [[a]] +treePaths (Node {rootLabel = r, subForest = []}) = [[r]] +treePaths (Node {rootLabel = r, subForest = ts}) = map (r :) (concatMap treePaths ts) + +pathEdges :: [a] -> [(a, a)] +pathEdges (v1 : v2 : vs) = (v1, v2) : pathEdges (v2 : vs) +pathEdges _ = [] + -- | Remove any packages which can't be built given that a package has failed. failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a]) failPackage cmp failed packages = @@ -243,16 +248,28 @@ checkPackageNameReq :: Relation -> BinPkgName -> Bool checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName +compareSource' :: HasDebianControl control => control -> control -> Ordering +compareSource' control1 control2 + | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT + | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT + | otherwise = EQ + where + bins1 = binaryNames' control1 + bins2 = binaryNames' control2 + depends1 = relations' control1 + depends2 = relations' control2 + checkPackageNameReq :: Relation -> BinPkgName -> Bool + checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName + -- |Return the dependency info for a list of control files. -genDeps :: [FilePath] -> IO [DepInfo] +genDeps :: [FilePath] -> IO [DebianControl] genDeps controlFiles = do - orderSource compareSource <$> mapM genDep' controlFiles + orderSource compareSource' <$> mapM genDep' controlFiles where -- Parse the control file and extract the build dependencies - genDep' :: FilePath -> IO DepInfo genDep' controlPath = parseControlFromFile controlPath >>= either (\ x -> throw (ParseRelationsError [$__LOC__] x)) - (\ x -> validateDebianControl x {- `mapExn` (pushLoc $__LOC__) -} >>= either throw (return . buildDependencies)) + (\ x -> validateDebianControl x {- `mapExn` (pushLoc $__LOC__) -} >>= either throw return) -- pushLoc :: Loc -> ControlFileError -> ControlFileError -- pushLoc loc e = e {locs = loc : locs e} @@ -264,7 +281,7 @@ -- order they should be built. getSourceOrder :: FilePath -> IO [SrcPkgName] getSourceOrder fp = - findControlFiles fp >>= genDeps >>= return . map sourceName + findControlFiles fp >>= genDeps >>= return . map sourceName' where -- Return a list of the files that look like debian\/control. findControlFiles :: FilePath -> IO [FilePath] diff --git a/Debian/Loc.hs b/Debian/Loc.hs --- a/Debian/Loc.hs +++ b/Debian/Loc.hs @@ -1,25 +1,23 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} -module Debian.Loc where +module Debian.Loc + ( __LOC__ + , mapExn + ) where -import Control.Applicative +import Control.Applicative ((<$>), (<*>), pure) import Control.Exception (Exception, throw) import Control.Monad.Catch (MonadCatch, catch) import Language.Haskell.TH -import Language.Haskell.TH.Syntax -deriving instance Show Loc - -instance Lift Loc where - lift x = recConE 'Loc [ (,) <$> (pure 'loc_filename) <*> litE (stringL (loc_filename x)) +__LOC__ :: Q Exp +__LOC__ = location >>= \ x -> + recConE 'Loc [ (,) <$> (pure 'loc_filename) <*> litE (stringL (loc_filename x)) , (,) <$> (pure 'loc_package) <*> litE (stringL (loc_package x)) , (,) <$> (pure 'loc_module) <*> litE (stringL (loc_module x)) , (,) <$> (pure 'loc_start) <*> [|($(litE (integerL (fromIntegral (fst (loc_start x))))), $(litE (integerL (fromIntegral (snd (loc_start x)))))) :: (Int, Int)|] , (,) <$> (pure 'loc_end) <*> [|($(litE (integerL (fromIntegral (fst (loc_end x))))), $(litE (integerL (fromIntegral (snd (loc_end x)))))) :: (Int, Int)|] ] - -__LOC__ :: Q Exp -__LOC__ = lift =<< location mapExn :: forall e m a. (MonadCatch m, Exception e) => m a -> (e -> e) -> m a mapExn task f = task `catch` (\ (e :: e) -> throw (f e)) diff --git a/Debian/Pretty.hs b/Debian/Pretty.hs --- a/Debian/Pretty.hs +++ b/Debian/Pretty.hs @@ -1,15 +1,22 @@ +-- | A constructor we can wrap around values to avoid any built in +-- Pretty instance - for example, instance Pretty [a]. +-- +-- * display is now prettyShow +-- * display' is now prettyText +-- * ppDisplay is now ppShow +-- * ppDisplay' is now ppText {-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} module Debian.Pretty ( PP(PP, unPP) - , display - , display' + , prettyShow + , prettyText , ppPrint - , ppDisplay - , ppDisplay' + , ppShow + , ppText ) where import Data.Text (Text, unpack, pack) -import Text.PrettyPrint.HughesPJClass (Doc, Pretty(pPrint), text, empty) +import Text.PrettyPrint.HughesPJClass (Doc, Pretty(pPrint), text, empty, prettyShow) -- | This type is wrapped around values before we pretty print them so -- we can write our own Pretty instances for common types without @@ -26,17 +33,14 @@ instance Pretty (PP a) => Pretty (PP (Maybe a)) where pPrint = maybe empty ppPrint . unPP -display :: Pretty a => a -> String -display = show . pPrint - -display' :: Pretty a => a -> Text -display' = pack .show . pPrint +prettyText :: Pretty a => a -> Text +prettyText = pack . prettyShow ppPrint :: Pretty (PP a) => a -> Doc ppPrint = pPrint . PP -ppDisplay :: Pretty (PP a) => a -> String -ppDisplay = display . PP +ppShow :: Pretty (PP a) => a -> String +ppShow = prettyShow . PP -ppDisplay' :: Pretty (PP a) => a -> Text -ppDisplay' = pack . display . PP +ppText :: Pretty (PP a) => a -> Text +ppText = pack . prettyShow . PP diff --git a/Debian/Sources.hs b/Debian/Sources.hs --- a/Debian/Sources.hs +++ b/Debian/Sources.hs @@ -12,22 +12,22 @@ data SourceType = Deb | DebSrc - deriving (Eq, Ord) + deriving (Eq, Ord, Show) data DebSource = DebSource { sourceType :: SourceType , sourceUri :: URI , sourceDist :: Either String (ReleaseName, [Section]) - } deriving (Eq, Ord) + } deriving (Eq, Ord, Show) -instance Pretty (PP SourceType) where - pPrint (PP Deb) = text "deb" - pPrint (PP DebSrc) = text "deb-src" +instance Pretty SourceType where + pPrint Deb = text "deb" + pPrint DebSrc = text "deb-src" -instance Pretty (PP DebSource) where - pPrint (PP (DebSource thetype theuri thedist)) = - pPrint (PP thetype) <> +instance Pretty DebSource where + pPrint (DebSource thetype theuri thedist) = + pPrint thetype <> text (" " <> uriToString id theuri " " <> case thedist of Left exactPath -> escape exactPath @@ -35,7 +35,7 @@ where escape = escapeURIString isAllowedInURI instance Pretty (PP [DebSource]) where - pPrint = hcat . map (\ x -> pPrint (PP x) <> text "\n") . unPP + pPrint = hcat . map (\ x -> pPrint x <> text "\n") . unPP -- |This is a name given to a combination of parts of one or more -- releases that can be specified by a sources.list file. diff --git a/Debian/Util/FakeChanges.hs b/Debian/Util/FakeChanges.hs --- a/Debian/Util/FakeChanges.hs +++ b/Debian/Util/FakeChanges.hs @@ -10,7 +10,7 @@ import Data.Foldable (concat, all, foldr) import Data.List as List (intercalate, nub, partition, isSuffixOf) import Data.Maybe -import Debian.Pretty (ppDisplay) +import Debian.Pretty (prettyShow) import Data.Traversable import Debian.Control import qualified Debian.Deb as Deb @@ -73,7 +73,7 @@ )) , ("Files", "\n" ++ unlines fileLines) ] - return $ (concat [ source, "_", version, "_", binArch, ".changes"], ppDisplay changes) + return $ (concat [ source, "_", version, "_", binArch, ".changes"], prettyShow changes) -- let (invalid, binaries) = unzipEithers $ map debNameSplit debs {- when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid]) @@ -218,13 +218,13 @@ case res of (Left e) -> error $ "Error parsing " ++ dsc' ++ "\n" ++ show e (Right (Control [p])) -> return (dsc', p) - (Right c) -> error $ dsc' ++ " did not have exactly one paragraph: " ++ ppDisplay c + (Right c) -> error $ dsc' ++ " did not have exactly one paragraph: " ++ prettyShow c loadDeb :: FilePath -> IO (FilePath, Paragraph) loadDeb deb = do res <- Deb.fields deb case res of (Control [p]) -> return (deb, p) - _ -> error $ deb ++ " did not have exactly one paragraph: " ++ ppDisplay res + _ -> error $ deb ++ " did not have exactly one paragraph: " ++ prettyShow res getUploader :: IO String diff --git a/Test/Changes.hs b/Test/Changes.hs --- a/Test/Changes.hs +++ b/Test/Changes.hs @@ -1,6 +1,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} -module Test.Changes where +module Changes where import Debian.Changes import Debian.Pretty (PP(..)) diff --git a/Test/Control.hs b/Test/Control.hs --- a/Test/Control.hs +++ b/Test/Control.hs @@ -1,18 +1,21 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings, StandaloneDeriving #-} -module Test.Control where +module Control where import Test.HUnit import Data.Monoid ((<>)) import Data.List as L (intercalate) import Data.Text as T (Text) +import Data.Version (showVersion) import Debian.Control import Debian.Control.Policy import Debian.Control.Text ({- Pretty instances -}) import Debian.Pretty (ppPrint, ppDisplay) import Debian.Relation import Debian.Version (parseDebianVersion) +import Paths_debian (version) import Text.Parsec.Error (ParseError) import Text.PrettyPrint.HughesPJClass (Doc, text) +import Text.Regex.TDFA ((=~), MatchResult(..)) instance Eq Doc where a == b = show a == show b @@ -23,6 +26,12 @@ -- deriving instance Show (Paragraph' Text) -- deriving instance Show (Field' Text) +replaceString :: String -> String -> String -> String +replaceString old new x = + case x =~ old of + mr | null (mrMatch mr) -> x + mr -> mrBefore mr <> new <> mrAfter mr + -- Additional tests of the results of parsing additional -- inter-paragraph newlines, or missing terminating newlines, would be -- good. @@ -41,12 +50,13 @@ , TestCase (parseDebianControlFromFile "Test/Control.hs" >>= \ vc -> assertEqual "policy4" -- Exceptions have bogus Eq instances, so we need to show then compare. - "Left (ParseControlError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (75,54), loc_end = (75,62)}], parseError = \"Test/Control.hs\" (line 0, column 0):\nFailed to parse Test/Control.hs})" + "Left \"./Debian/Control/Policy.hs\"(line 77, column 54): ParseControlError \"Test/Control.hs\" (line 0, column 0):\nFailed to parse Test/Control.hs" (show (either Left (either Left Right . debianRelations "Foo") vc))) , TestCase (parseDebianControlFromFile "nonexistant" >>= \ vc -> assertEqual "policy5" - "Left (IOError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (74,36), loc_end = (74,44)}], ioError = nonexistant: openBinaryFile: does not exist (No such file or directory)})" - (show (either Left (debianRelations "Foo") (vc :: Either ControlFileError DebianControl)))) + "Left \"./Debian/Control/Policy.hs\"(line 76, column 36): IOError nonexistant: openBinaryFile: does not exist (No such file or directory)" + (replaceString "openFile" "openBinaryFile" + (show (either Left (debianRelations "Foo") (vc :: Either ControlFileError DebianControl))))) -- Test whether embedded newlines in field values can be mistaken -- for field or paragraph divisions. In cases pretty7 and pretty9 diff --git a/Test/Dependencies.hs b/Test/Dependencies.hs --- a/Test/Dependencies.hs +++ b/Test/Dependencies.hs @@ -1,6 +1,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} -module Test.Dependencies where +module Dependencies where import Control.Arrow import Test.HUnit diff --git a/Test/Main.hs b/Test/Main.hs --- a/Test/Main.hs +++ b/Test/Main.hs @@ -2,12 +2,11 @@ import Test.HUnit import System.Exit -import Test.Changes -import Test.Control -import Test.Versions ---import Test.VersionPolicy -import Test.SourcesList -import Test.Dependencies +import Changes +import Control +import Versions +import SourcesList +import Dependencies import Text.PrettyPrint.ANSI.Leijen (Doc, text, (<+>), (<$>), fillSep, renderPretty, displayS) main = diff --git a/Test/SourcesList.hs b/Test/SourcesList.hs --- a/Test/SourcesList.hs +++ b/Test/SourcesList.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.SourcesList where +module SourcesList where import Data.Text (Text) import Data.Monoid (mconcat, (<>)) diff --git a/Test/VersionPolicy.hs b/Test/VersionPolicy.hs deleted file mode 100644 --- a/Test/VersionPolicy.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Test.VersionPolicy where - -import Test.HUnit - -import Debian.Version -import Debian.VersionPolicy - --- * Tag parsing - -versionPolicyTests = - map (\ (vendor, release, versionString) -> - let version = (parseDebianVersion versionString) in - TestCase (assertEqual versionString (rebuildTag vendor version) version)) versionStrings ++ - [ TestCase (assertEqual - "setTag" - (parseDebianVersion "1.2-3seereason4~feisty7") - (either (error "setTag failed!") id - (setTag id "seereason" (Just "feisty") Nothing - -- version currently uploaded to the build release - (Just (parseDebianVersion "1.2-3seereason4~feisty4")) - -- All the versions in the repository - [parseDebianVersion "1.2-3seereason4~feisty5", - parseDebianVersion "1.2-3seereason4~feisty6"] - -- The version retrieved from the changelog - (parseDebianVersion "1.2-3seereason4")))) - , TestCase (assertEqual - "setTag2" - (Right (parseDebianVersion "3000.0.2.1-2+6seereason1~feisty1")) - (setTag id "seereason" (Just "feisty") Nothing - (Just (parseDebianVersion "3000.0.2.1-1+6seereason1~feisty3")) - [parseDebianVersion "3000.0.2.1-1+6seereason3", - parseDebianVersion "3000.0.2.1-1+6seereason1~feisty3", - parseDebianVersion "3000.0.2.1-1+6seereason1~feisty2", - parseDebianVersion "3000.0.2.1-1+6seereason1~feisty1", - parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy4", - parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy3", - parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy2", - parseDebianVersion "3000.0.2-2+6"] - (parseDebianVersion "3000.0.2.1-2+6"))) - , TestCase (assertEqual - "setTag" - (parseDebianVersion "0.4.0.1") - (fst (parseTag "seereason" (parseDebianVersion "0.4.0.1-0seereason1")))) - , TestCase (assertEqual - "appendTag (parseTag \"seereason\" (parseDebianVersion \"0.4.0.1-0seereason1\")) -> \"0.4.0.1-0seereason1\"" - (parseDebianVersion "0.4.0.1-0seereason1") - (uncurry (appendTag id) (parseTag "seereason" (parseDebianVersion "0.4.0.1-0seereason1")))) - , TestCase (assertEqual - "setTag \"seereason\" (Just \"gutsy\") \"0.4.0.1-0seereason1\" -> \"0.4.0.1-0seereason1~gutsy1\"" - (parseDebianVersion "0.4.0.1-0seereason1~gutsy1") - (either (error "setTag failed!") id - (setTag id "seereason" (Just "gutsy") Nothing - -- version currently uploaded to the build release - Nothing - -- All the versions in the repository - [] - -- The version retrieved from the changelog - (parseDebianVersion "0.4.0.1-0seereason1")))) ] - -versionStrings = [ ("seereason", Just "feisty", "1.2-3seereason4~feisty5") - , ("seereason", Just "feisty", "1.2-3") - , ("seereason", Nothing, "1.2-3seereason4") - , ("seereason", Nothing, "1.2-0seereason4") ] - -rebuildTag vendor version = - case parseTag vendor version of - (version, Just tag) -> appendTag id version (Just tag) - (version, Nothing) -> version diff --git a/Test/Versions.hs b/Test/Versions.hs --- a/Test/Versions.hs +++ b/Test/Versions.hs @@ -1,5 +1,5 @@ {-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} -module Test.Versions where +module Versions where import Test.HUnit diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,28 @@ +haskell-debian (3.86) unstable; urgency=low + + * Avoid dependency on th-orphans + * Turn test program into a test-suite + * add DEB_ENABLE_TESTS = yes to debian/rules + * Support builds on older versions of GHC + + -- David Fox Sun, 15 Feb 2015 07:32:42 -0800 + +haskell-debian (3.85.3) unstable; urgency=low + + * Handle new pretty-1.1.2 package, which supercedes prettyclass. + * Make a change to trigger a travis build. + + -- David Fox Fri, 06 Feb 2015 10:18:30 -0800 + +haskell-debian (3.85.2) unstable; urgency=low + + * If any of the lines of a multi-line control file field are not + indented, indent all the lines by one space. + * When formatting multi-line control file fields, make sure empty + lines are replaced by a single (indented) '.'. + + -- David Fox Wed, 04 Feb 2015 11:23:42 -0800 + haskell-debian (3.85.1) unstable; urgency=low * Allow build with process-extras-0.2.0 diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.85.2 +Version: 3.87 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers @@ -14,12 +14,16 @@ the Debian policy manual - version numbers, control file syntax, etc. extra-source-files: Test/Main.hs, Test/Changes.hs, Test/Dependencies.hs, - Test/SourcesList.hs, Test/VersionPolicy.hs, Test/Versions.hs, Test/Control.hs, changelog, debian/changelog, debian/changelog.pre-debian + Test/SourcesList.hs, Test/Versions.hs, Test/Control.hs, changelog, debian/changelog, debian/changelog.pre-debian flag network-uri Description: Get Network.URI from the network-uri package Default: True +flag pretty-new + Description: pretty-1.1.2 includes the Text.PrettyPrint.HughesPJClass module from prettyclass + Default: True + Library Hs-Source-Dirs: . Build-Depends: @@ -37,8 +41,6 @@ mtl, old-locale, parsec >= 2 && <4, - pretty, - prettyclass, process, process-extras >= 0.2.0, pureMD5, @@ -48,13 +50,17 @@ text, time, unix, - Unixutils >= 1.50, + Unixutils >= 1.52.4, utf8-string, zlib if flag(network-uri) Build-Depends: network >= 2.6, network-uri >= 2.6 else Build-Depends: network >= 2.4 && < 2.6 + if flag(pretty-new) + Build-Depends: pretty >= 1.1.2 + else + Build-Depends: pretty, prettyclass ghc-options: -Wall -O2 Exposed-modules: @@ -93,11 +99,7 @@ Debian.UTF8, Debian.Util.FakeChanges other-modules: - Debian.Version.Internal, - Test.Changes, - Test.Dependencies, - Test.SourcesList, - Test.Versions + Debian.Version.Internal Executable fakechanges Hs-Source-Dirs: utils @@ -124,14 +126,15 @@ ghc-options: -threaded -W -O2 Extensions: ExistentialQuantification CPP -Executable debian-tests - Main-is: Test/Main.hs - ghc-options: -threaded -W -O2 - Build-Depends: ansi-wl-pprint, base, bytestring, containers, debian, directory, exceptions, HUnit, ListLike >= 4.1.1, mtl, parsec, pretty, prettyclass, process, process-extras >= 0.2.0, regex-compat, regex-tdfa, template-haskell, text, utf8-string - if flag(network-uri) - Build-Depends: network >= 2.6, network-uri >= 2.6 +Test-Suite debian-tests + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: Test + Main-Is: Main.hs + Build-Depends: ansi-wl-pprint, base, debian, HUnit, parsec, regex-tdfa, text + if flag(pretty-new) + Build-Depends: pretty >= 1.1.2 else - Build-Depends: network >= 2.4 && < 2.6 + Build-Depends: pretty, prettyclass source-repository head type: git diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,19 @@ +haskell-debian (3.86) unstable; urgency=low + + * Avoid dependency on th-orphans + * Turn test program into a test-suite + * add DEB_ENABLE_TESTS = yes to debian/rules + * Support builds on older versions of GHC + + -- David Fox Sun, 15 Feb 2015 07:32:42 -0800 + +haskell-debian (3.85.3) unstable; urgency=low + + * Handle new pretty-1.1.2 package, which supercedes prettyclass. + * Make a change to trigger a travis build. + + -- David Fox Fri, 06 Feb 2015 10:18:30 -0800 + haskell-debian (3.85.2) unstable; urgency=low * If any of the lines of a multi-line control file field are not