cblrepo 0.20.0 → 0.21.0
raw patch · 8 files changed
+562/−323 lines, 8 filesdep +vectordep ~aeson
Dependencies added: vector
Dependency ranges changed: aeson
Files
- cblrepo.cabal +6/−3
- src/ConvertDB.hs +1/−1
- src/Main.hs +1/−1
- src/OldPkgDB.hs +87/−151
- src/OldPkgTypes.hs +191/−0
- src/PkgDB.hs +84/−166
- src/PkgTypes.hs +191/−0
- src/Util/Misc.hs +1/−1
cblrepo.cabal view
@@ -1,5 +1,5 @@ name: cblrepo-version: 0.20.0+version: 0.21.0 cabal-version: >= 1.6 license: OtherLicense license-file: LICENSE-2.0@@ -32,8 +32,10 @@ Extract ListPkgs OldPkgDB+ OldPkgTypes PkgBuild PkgDB+ PkgTypes Remove Update Upgrades@@ -58,13 +60,14 @@ Unixutils ==1.54.*, unix ==2.7.*, ansi-wl-pprint ==0.6.*,- aeson ==0.10.*,+ aeson ==0.11.*, stringsearch ==0.3.*, optparse-applicative ==0.12.*, safe ==0.3.*, containers ==0.5.*, utf8-string ==1.0.*,- text+ text,+ vector Source-Repository head Type: git
src/ConvertDB.hs view
@@ -43,7 +43,7 @@ where n = ODB.pkgName o v = ODB.pkgVersion o- x = 0+ x = ODB.pkgXRev o d = ODB.pkgDeps o f = ODB.pkgFlags o r = ODB.pkgRelease o
src/Main.hs view
@@ -51,7 +51,7 @@ <$> strOption (long "patchdir" <> value "patches" <> showDefault <> help "Location of patches") <*> option ghcVersionArgReader (long "ghc-version" <> value ghcDefVersion <> showDefault <> help "GHC version to use") <*> many (option ghcPkgArgReader (short 'g' <> long "ghc-pkg" <> metavar "PKG,VER" <> help "GHC base package (multiple)"))- <*> many (option distroPkgArgReader (short 'd' <> long "distro-pkg" <> metavar "PKG,VER,REL" <> help "Distro package (multiple)"))+ <*> many (option distroPkgArgReader (short 'd' <> long "distro-pkg" <> metavar "PKG,VER,XREV,REL" <> help "Distro package (multiple)")) <*> many (option strCblFileArgReader (short 'f' <> long "cbl-file" <> metavar "FILE[:flag,-flag]" <> help "CABAL file (multiple)")) <*> many (argument strCblPkgArgReader (metavar "PKGNAME,VERSION[:flag,-flag] ..."))
src/OldPkgDB.hs view
@@ -14,97 +14,57 @@ - limitations under the License. -} -{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module OldPkgDB- ( CblPkg- , pkgName- , pkgPkg- , pkgVersion- , pkgXRev- , pkgDeps- , pkgFlags- , pkgRelease- --- , isGhcPkg- , isDistroPkg- , isRepoPkg- , isBasePkg- --- , createGhcPkg- , createDistroPkg- , createRepoPkg- , createCblPkg- --- , CblDB- , addPkg- , addPkg2- , delPkg- , bumpRelease- , lookupPkg- , transitiveDependants- , checkDependants- , checkAgainstDb- , saveDb- , readDb- ) where+ ( CblPkg+ , pkgName+ , pkgPkg+ , pkgVersion+ , pkgXRev+ , pkgDeps+ , pkgFlags+ , pkgRelease+ --+ , isGhcPkg+ , isDistroPkg+ , isRepoPkg+ , isBasePkg+ --+ , createGhcPkg+ , createDistroPkg+ , createRepoPkg+ , createCblPkg+ --+ , CblDB+ , addPkg+ , addPkg2+ , delPkg+ , bumpRelease+ , lookupPkg+ , transitiveDependants+ , checkDependants+ , checkAgainstDb+ , saveDb+ , readDb+ ) where -- {{{1 imports-import Control.Arrow-import Control.Exception as CE-import Control.Monad-import Data.List-import Data.Maybe-import Data.Monoid-import Distribution.PackageDescription-import System.IO.Error+import Control.Arrow+import Control.Exception as CE+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as C+import Data.List+import Data.Maybe import qualified Distribution.Package as P+import Distribution.PackageDescription import qualified Distribution.Version as V--import Data.Aeson-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))-import qualified Data.ByteString.Lazy.Char8 as C+import System.IO.Error import qualified Util.Dist---- {{{1 types-data Pkg- = GhcPkg GhcPkgD- | DistroPkg DistroPkgD- | RepoPkg RepoPkgD- deriving (Eq, Show)--data GhcPkgD = GhcPkgD { gpVersion :: V.Version }- deriving (Eq, Show)--data DistroPkgD = DistroPkgD { dpVersion :: V.Version , dpRelease :: Int }- deriving (Eq, Show)--data RepoPkgD = RepoPkgD- { rpVersion :: V.Version- , rpXrev :: Int- , rpDeps :: [P.Dependency]- , rpFlags :: FlagAssignment, rpRelease :: Int- } deriving (Eq, Show)--data CblPkg = CP String Pkg- deriving (Eq, Show)--type CblDB = [CblPkg]--instance Ord CblPkg where- compare (CP n1 (GhcPkg d1)) (CP n2 (GhcPkg d2)) =- compare (n1, gpVersion d1) (n2, gpVersion d2)- compare (CP _ GhcPkg {}) _ = LT- compare _ (CP _ GhcPkg {}) = GT-- compare (CP n1 (DistroPkg d1)) (CP n2 (DistroPkg d2)) =- compare (n1, dpVersion d1, dpRelease d1) (n2, dpVersion d2, dpRelease d2)- compare (CP _ DistroPkg {}) _ = LT- compare _ (CP _ DistroPkg {}) = GT-- compare (CP n1 (RepoPkg d1)) (CP n2 (RepoPkg d2)) =- compare (n1, rpVersion d1, rpRelease d1) (n2, rpVersion d2, rpRelease d2)+import OldPkgTypes -- {{{1 packages pkgName :: CblPkg -> String@@ -119,6 +79,7 @@ pkgVersion (CP _ (RepoPkg d)) = rpVersion d pkgXRev :: CblPkg -> Int+pkgXRev (CP _ (DistroPkg d)) = dpXrev d pkgXRev (CP _ (RepoPkg d)) = rpXrev d pkgXRev _ = 0 @@ -131,26 +92,26 @@ pkgFlags _ = [] pkgRelease :: CblPkg -> Int-pkgRelease (CP _ (GhcPkg _)) = (-1)+pkgRelease (CP _ (GhcPkg _)) = -1 pkgRelease (CP _ (DistroPkg d)) = dpRelease d pkgRelease (CP _ (RepoPkg d)) = rpRelease d createGhcPkg :: String -> V.Version -> CblPkg createGhcPkg n v = CP n (GhcPkg $ GhcPkgD v) -createDistroPkg :: String -> V.Version -> Int -> CblPkg-createDistroPkg n v r = CP n (DistroPkg (DistroPkgD v r))+createDistroPkg :: String -> V.Version -> Int -> Int -> CblPkg+createDistroPkg n v x r = CP n (DistroPkg (DistroPkgD v x r)) createRepoPkg :: String -> V.Version -> Int -> [P.Dependency] -> FlagAssignment -> Int -> CblPkg createRepoPkg n v x d fa r = CP n (RepoPkg $ RepoPkgD v x d fa r) createCblPkg :: PackageDescription -> FlagAssignment -> CblPkg createCblPkg pd fa = createRepoPkg name version xrev deps fa 1- where- name = Util.Dist.pkgNameStr pd- version = P.pkgVersion $ package pd- xrev = Util.Dist.pkgXRev pd- deps = buildDepends pd+ where+ name = Util.Dist.pkgNameStr pd+ version = P.pkgVersion $ package pd+ xrev = Util.Dist.pkgXRev pd+ deps = buildDepends pd getDependencyOn :: String -> CblPkg -> Maybe P.Dependency getDependencyOn n p = find (\ d -> Util.Dist.depName d == n) (pkgDeps p)@@ -176,92 +137,67 @@ addPkg :: CblDB -> String -> Pkg -> CblDB addPkg db n p = nubBy cmp newdb- where- cmp (CP n1 _) (CP n2 _) = n1 == n2- newdb = CP n p:db+ where+ cmp (CP n1 _) (CP n2 _) = n1 == n2+ newdb = CP n p:db addPkg2 :: CblDB -> CblPkg -> CblDB addPkg2 db (CP n p) = addPkg db n p -addGhcPkg :: CblDB -> String -> V.Version -> CblDB-addGhcPkg db n v = addPkg2 db (createGhcPkg n v)--addDistroPkg :: CblDB -> String -> V.Version -> Int -> CblDB-addDistroPkg db n v r = addPkg2 db (createDistroPkg n v r)- delPkg :: CblDB -> String -> CblDB delPkg db n = filter (\ p -> n /= pkgName p) db bumpRelease :: CblDB -> String -> CblDB bumpRelease db n = maybe db (addPkg2 db . doBump) (lookupPkg db n)- where- doBump (CP n' (RepoPkg d)) = CP n' (RepoPkg d { rpRelease = (rpRelease d + 1) })- doBump p = p+ where+ doBump (CP n' (RepoPkg d)) = CP n' (RepoPkg d { rpRelease = rpRelease d + 1 })+ doBump p = p lookupPkg :: CblDB -> String -> Maybe CblPkg lookupPkg [] _ = Nothing lookupPkg (p:db) n- | n == pkgName p = Just p- | otherwise = lookupPkg db n+ | n == pkgName p = Just p+ | otherwise = lookupPkg db n lookupDependants :: [CblPkg] -> String -> [String] lookupDependants db n = filter (/= n) $ map pkgName $ filter (`doesDependOn` n) db- where- doesDependOn p n = n `elem` map Util.Dist.depName (pkgDeps p)+ where+ doesDependOn p n' = n' `elem` map Util.Dist.depName (pkgDeps p) transitiveDependants :: CblDB -> [String] -> [String] transitiveDependants db names = keepLast $ concatMap transUsersOfOne names- where- transUsersOfOne n = n : transitiveDependants db (lookupDependants db n)- keepLast = reverse . nub . reverse+ where+ transUsersOfOne n = n : transitiveDependants db (lookupDependants db n)+ keepLast = reverse . nub . reverse checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)]-checkDependants db n v = let- d1 = mapMaybe (lookupPkg db) (lookupDependants db n)- -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1- d2 = map (pkgName &&& getDependencyOn n ) d1- fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2- in fails+checkDependants db n v =+ let d1 = mapMaybe (lookupPkg db) (lookupDependants db n)+ -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1+ d2 = map (pkgName &&& getDependencyOn n ) d1+ fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2+ in fails checkAgainstDb :: CblDB -> String -> P.Dependency -> Bool-checkAgainstDb db name dep = let- dN = Util.Dist.depName dep- dVR = Util.Dist.depVersionRange dep- in (dN == name) ||- (case lookupPkg db dN of- Nothing -> False- Just p -> V.withinRange (pkgVersion p) dVR)+checkAgainstDb db name dep =+ let dN = Util.Dist.depName dep+ dVR = Util.Dist.depVersionRange dep+ in (dN == name) ||+ (case lookupPkg db dN of+ Nothing -> False+ Just p -> V.withinRange (pkgVersion p) dVR) readDb :: FilePath -> IO CblDB readDb fp = handle- (\ e -> if isDoesNotExistError e- then return emptyPkgDB- else throwIO e)- $ do- r <- (mapM decode . C.lines) `liftM` C.readFile fp- case r of- Just a -> return a- Nothing -> fail "JSON parsing failed"+ (\ e -> if isDoesNotExistError e+ then return emptyPkgDB+ else throwIO e)+ $ do r <- (mapM decode . C.lines) `liftM` C.readFile fp+ case r of+ Just a -> return a+ Nothing -> fail "JSON parsing failed" saveDb :: CblDB -> FilePath -> IO () saveDb db fp = C.writeFile fp s- where- s = C.unlines $ map encode $ sort db---- {{{1 JSON instances-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.Version)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.VersionRange)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''FlagName)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''GhcPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''DistroPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''RepoPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg)--instance ToJSON P.Dependency where- toJSON (P.Dependency pn vr) = toJSON (P.unPackageName pn, vr)--instance FromJSON P.Dependency where- parseJSON v = do- (pn, vr) <- parseJSON v- return $ P.Dependency (P.PackageName pn) vr+ where+ s = C.unlines $ map encode $ sort db
+ src/OldPkgTypes.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++{-+ - Copyright 2011-2015 Per Magnus Therning+ -+ - Licensed under the Apache License, Version 2.0 (the "License");+ - you may not use this file except in compliance with the License.+ - You may obtain a copy of the License at+ -+ - http://www.apache.org/licenses/LICENSE-2.0+ -+ - Unless required by applicable law or agreed to in writing, software+ - distributed under the License is distributed on an "AS IS" BASIS,+ - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ - See the License for the specific language governing permissions and+ - limitations under the License.+ -}++module OldPkgTypes where++import Control.Applicative+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.TH (deriveJSON)+import Data.Text (unpack)+import qualified Data.Version as DV+import qualified Distribution.Package as P+import Distribution.PackageDescription+import qualified Distribution.Version as V+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Data.Vector as Vec++data Pkg = GhcPkg GhcPkgD+ | DistroPkg DistroPkgD+ | RepoPkg RepoPkgD+ deriving (Eq, Show)++data GhcPkgD = GhcPkgD { gpVersion :: V.Version }+ deriving (Eq, Show)++data DistroPkgD = DistroPkgD+ { dpVersion :: V.Version+ , dpXrev :: Int+ , dpRelease :: Int+ } deriving (Eq, Show)++data RepoPkgD = RepoPkgD+ { rpVersion :: V.Version+ , rpXrev :: Int+ , rpDeps :: [P.Dependency]+ , rpFlags :: FlagAssignment+ , rpRelease :: Int+ } deriving (Eq, Show)++data CblPkg = CP String Pkg+ deriving (Eq, Show)++type CblDB = [CblPkg]++instance Ord CblPkg where+ compare (CP n1 (GhcPkg d1)) (CP n2 (GhcPkg d2)) =+ compare (n1, gpVersion d1) (n2, gpVersion d2)+ compare (CP _ GhcPkg {}) _ = LT+ compare _ (CP _ GhcPkg {}) = GT++ compare (CP n1 (DistroPkg d1)) (CP n2 (DistroPkg d2)) =+ compare (n1, dpVersion d1, dpRelease d1) (n2, dpVersion d2, dpRelease d2)+ compare (CP _ DistroPkg {}) _ = LT+ compare _ (CP _ DistroPkg {}) = GT++ compare (CP n1 (RepoPkg d1)) (CP n2 (RepoPkg d2)) =+ compare (n1, rpVersion d1, rpRelease d1) (n2, rpVersion d2, rpRelease d2)++-- JSON instances+version2Json :: V.Version -> Value+version2Json = toJSON . DV.showVersion++json2Version :: Value -> Parser V.Version+json2Version = withText "Version" $ go . readP_to_S DV.parseVersion . unpack+ where+ go [(v,[])] = return v+ go (_ : xs) = go xs+ go _ = fail "could not parse Version"++dependencyList2Json :: [P.Dependency] -> Value+dependencyList2Json = toJSON . map convDep+ where+ convDep (P.Dependency (P.PackageName n) vr)= (n, versionRange2Json vr)++json2DependencyList :: Value -> Parser [P.Dependency]+json2DependencyList = withArray "DependencyList" parseList+ where+ parseList = mapM (withArray "Dependency" parseDep) . Vec.toList++ parseDep a = do+ n <- withText "PackageName" (return . unpack) (a Vec.! 0)+ vr <- json2VersionRange (a Vec.! 1)+ return $ P.Dependency (P.PackageName n) vr++versionRange2Json :: V.VersionRange -> Value+versionRange2Json = V.foldVersionRange+ (object ["AnyVersion" .= ([]::[(Int,Int)])])+ (\ v -> object ["ThisVersion" .= version2Json v])+ (\ v -> object ["LaterVersion" .= version2Json v])+ (\ v -> object ["EarlierVersion" .= version2Json v])+ (\ vr0 vr1 -> object ["UnionVersionRanges" .= [vr0, vr1]])+ (\ vr0 vr1 -> object ["IntersectVersionRanges" .= [vr0, vr1]])++json2VersionRange :: Value -> Parser V.VersionRange+json2VersionRange = withObject "VersionRange" go+ where+ go :: Object -> Parser V.VersionRange+ go o =+ V.thisVersion <$> (o .: "ThisVersion" >>= json2Version) <|>+ V.laterVersion <$> (o .: "LaterVersion" >>= json2Version) <|>+ V.earlierVersion <$> (o .: "EarlierVersion" >>= json2Version) <|>+ V.WildcardVersion <$> (o .: "WildcardVersion" >>= json2Version) <|>+ nullaryOp V.anyVersion <$> o .: "AnyVersion" <|>+ (o .: "UnionVersionRanges" >>= parserPair V.unionVersionRanges) <|>+ (o .: "IntersectVersionRanges" >>= parserPair V.intersectVersionRanges) <|>+ V.VersionRangeParens <$> (o .: "VersionRangeParens" >>= json2VersionRange)++ nullaryOp :: a -> Value -> a+ nullaryOp = const++ parserPair :: (V.VersionRange -> V.VersionRange -> V.VersionRange) -> Value -> Parser V.VersionRange+ parserPair f = withArray "parserPair" p+ where+ p a = do+ v1 <- json2VersionRange (a Vec.! 0)+ v2 <- json2VersionRange (a Vec.! 1)+ return $ f v1 v2++flagAssignment2Json :: FlagAssignment -> Value+flagAssignment2Json = toJSON . map convFlag+ where+ convFlag (FlagName s, b) = (s, b)++json2FlagAssignment :: Value -> Parser FlagAssignment+json2FlagAssignment = withArray "FlagAssignment" parseList+ where+ parseList = mapM (withArray "SingleFlag" parseFlag) . Vec.toList++ parseFlag a = do+ n <- withText "FlagName" (return . unpack) (a Vec.! 0)+ b <- withBool "FlagBool" return (a Vec.! 1)+ return (FlagName n, b)++instance ToJSON GhcPkgD where+ toJSON (GhcPkgD v) = object ["gpVersion" .= version2Json v]++instance FromJSON GhcPkgD where+ parseJSON = withObject "GhcPkgD" (\ o -> GhcPkgD <$> (o .: "gpVersion" >>= json2Version))++instance ToJSON DistroPkgD where+ toJSON (DistroPkgD v x r)= object [ "dpVersion" .= version2Json v+ , "dpXrev" .= x+ , "dpRelease" .= r+ ]++instance FromJSON DistroPkgD where+ parseJSON = withObject "DistroPkgD" go+ where+ go o = do+ v <- o .: "dpVersion" >>= json2Version+ x <- o .: "dpXrev"+ r <- o .: "dpRelease"+ return $ DistroPkgD v x r++instance ToJSON RepoPkgD where+ toJSON (RepoPkgD v x ds fs r)= object [ "rpVersion" .= version2Json v+ , "rpXrev" .= x+ , "rpDeps" .= dependencyList2Json ds+ , "rpFlags" .= flagAssignment2Json fs+ , "rpRelease" .= r+ ]++instance FromJSON RepoPkgD where+ parseJSON = withObject "RepoPkgD" go+ where+ go o = do+ v <- o .: "rpVersion" >>= json2Version+ x <- o .: "rpXrev"+ ds <- o .: "rpDeps" >>= json2DependencyList+ fs <- o .: "rpFlags" >>= json2FlagAssignment+ r <- o .: "rpRelease"+ return $ RepoPkgD v x ds fs r++$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg)+$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg)
src/PkgDB.hs view
@@ -14,103 +14,57 @@ - limitations under the License. -} -{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module PkgDB- ( CblPkg- , pkgName- , pkgPkg- , pkgVersion- , pkgXRev- , pkgDeps- , pkgFlags- , pkgRelease- --- , isGhcPkg- , isDistroPkg- , isRepoPkg- , isBasePkg- --- , createGhcPkg- , createDistroPkg- , createRepoPkg- , createCblPkg- --- , CblDB- , addPkg- , addPkg2- , delPkg- , bumpRelease- , lookupPkg- , transitiveDependants- , checkDependants- , checkAgainstDb- , saveDb- , readDb- ) where+ ( CblPkg+ , pkgName+ , pkgPkg+ , pkgVersion+ , pkgXRev+ , pkgDeps+ , pkgFlags+ , pkgRelease+ --+ , isGhcPkg+ , isDistroPkg+ , isRepoPkg+ , isBasePkg+ --+ , createGhcPkg+ , createDistroPkg+ , createRepoPkg+ , createCblPkg+ --+ , CblDB+ , addPkg+ , addPkg2+ , delPkg+ , bumpRelease+ , lookupPkg+ , transitiveDependants+ , checkDependants+ , checkAgainstDb+ , saveDb+ , readDb+ ) where -- {{{1 imports-import Control.Arrow-import Control.Exception as CE-import Control.Monad-import Data.List-import Data.Maybe-import Data.Monoid-import Distribution.PackageDescription-import System.IO.Error+import Control.Arrow+import Control.Exception as CE+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as C+import Data.List+import Data.Maybe import qualified Distribution.Package as P+import Distribution.PackageDescription import qualified Distribution.Version as V-import qualified Data.Version as DV-import Text.ParserCombinators.ReadP (readP_to_S)-import Data.Text (unpack)--import Data.Aeson-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))-import qualified Data.ByteString.Lazy.Char8 as C+import System.IO.Error import qualified Util.Dist---- {{{1 types-data Pkg- = GhcPkg GhcPkgD- | DistroPkg DistroPkgD- | RepoPkg RepoPkgD- deriving (Eq, Show)--data GhcPkgD = GhcPkgD { gpVersion :: V.Version }- deriving (Eq, Show)--data DistroPkgD = DistroPkgD- { dpVersion :: V.Version- , dpXrev :: Int- , dpRelease :: Int- } deriving (Eq, Show)--data RepoPkgD = RepoPkgD- { rpVersion :: V.Version- , rpXrev :: Int- , rpDeps :: [P.Dependency]- , rpFlags :: FlagAssignment, rpRelease :: Int- } deriving (Eq, Show)--data CblPkg = CP String Pkg- deriving (Eq, Show)--type CblDB = [CblPkg]--instance Ord CblPkg where- compare (CP n1 (GhcPkg d1)) (CP n2 (GhcPkg d2)) =- compare (n1, gpVersion d1) (n2, gpVersion d2)- compare (CP _ GhcPkg {}) _ = LT- compare _ (CP _ GhcPkg {}) = GT-- compare (CP n1 (DistroPkg d1)) (CP n2 (DistroPkg d2)) =- compare (n1, dpVersion d1, dpRelease d1) (n2, dpVersion d2, dpRelease d2)- compare (CP _ DistroPkg {}) _ = LT- compare _ (CP _ DistroPkg {}) = GT-- compare (CP n1 (RepoPkg d1)) (CP n2 (RepoPkg d2)) =- compare (n1, rpVersion d1, rpRelease d1) (n2, rpVersion d2, rpRelease d2)+import PkgTypes -- {{{1 packages pkgName :: CblPkg -> String@@ -138,7 +92,7 @@ pkgFlags _ = [] pkgRelease :: CblPkg -> Int-pkgRelease (CP _ (GhcPkg _)) = (-1)+pkgRelease (CP _ (GhcPkg _)) = -1 pkgRelease (CP _ (DistroPkg d)) = dpRelease d pkgRelease (CP _ (RepoPkg d)) = rpRelease d @@ -153,11 +107,11 @@ createCblPkg :: PackageDescription -> FlagAssignment -> CblPkg createCblPkg pd fa = createRepoPkg name version xrev deps fa 1- where- name = Util.Dist.pkgNameStr pd- version = P.pkgVersion $ package pd- xrev = Util.Dist.pkgXRev pd- deps = buildDepends pd+ where+ name = Util.Dist.pkgNameStr pd+ version = P.pkgVersion $ package pd+ xrev = Util.Dist.pkgXRev pd+ deps = buildDepends pd getDependencyOn :: String -> CblPkg -> Maybe P.Dependency getDependencyOn n p = find (\ d -> Util.Dist.depName d == n) (pkgDeps p)@@ -183,103 +137,67 @@ addPkg :: CblDB -> String -> Pkg -> CblDB addPkg db n p = nubBy cmp newdb- where- cmp (CP n1 _) (CP n2 _) = n1 == n2- newdb = CP n p:db+ where+ cmp (CP n1 _) (CP n2 _) = n1 == n2+ newdb = CP n p:db addPkg2 :: CblDB -> CblPkg -> CblDB addPkg2 db (CP n p) = addPkg db n p -addGhcPkg :: CblDB -> String -> V.Version -> CblDB-addGhcPkg db n v = addPkg2 db (createGhcPkg n v)--addDistroPkg :: CblDB -> String -> V.Version -> Int -> Int -> CblDB-addDistroPkg db n v x r = addPkg2 db (createDistroPkg n v x r)- delPkg :: CblDB -> String -> CblDB delPkg db n = filter (\ p -> n /= pkgName p) db bumpRelease :: CblDB -> String -> CblDB bumpRelease db n = maybe db (addPkg2 db . doBump) (lookupPkg db n)- where- doBump (CP n' (RepoPkg d)) = CP n' (RepoPkg d { rpRelease = (rpRelease d + 1) })- doBump p = p+ where+ doBump (CP n' (RepoPkg d)) = CP n' (RepoPkg d { rpRelease = rpRelease d + 1 })+ doBump p = p lookupPkg :: CblDB -> String -> Maybe CblPkg lookupPkg [] _ = Nothing lookupPkg (p:db) n- | n == pkgName p = Just p- | otherwise = lookupPkg db n+ | n == pkgName p = Just p+ | otherwise = lookupPkg db n lookupDependants :: [CblPkg] -> String -> [String] lookupDependants db n = filter (/= n) $ map pkgName $ filter (`doesDependOn` n) db- where- doesDependOn p n = n `elem` map Util.Dist.depName (pkgDeps p)+ where+ doesDependOn p n' = n' `elem` map Util.Dist.depName (pkgDeps p) transitiveDependants :: CblDB -> [String] -> [String] transitiveDependants db names = keepLast $ concatMap transUsersOfOne names- where- transUsersOfOne n = n : transitiveDependants db (lookupDependants db n)- keepLast = reverse . nub . reverse+ where+ transUsersOfOne n = n : transitiveDependants db (lookupDependants db n)+ keepLast = reverse . nub . reverse checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)]-checkDependants db n v = let- d1 = mapMaybe (lookupPkg db) (lookupDependants db n)- -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1- d2 = map (pkgName &&& getDependencyOn n ) d1- fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2- in fails+checkDependants db n v =+ let d1 = mapMaybe (lookupPkg db) (lookupDependants db n)+ -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1+ d2 = map (pkgName &&& getDependencyOn n ) d1+ fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2+ in fails checkAgainstDb :: CblDB -> String -> P.Dependency -> Bool-checkAgainstDb db name dep = let- dN = Util.Dist.depName dep- dVR = Util.Dist.depVersionRange dep- in (dN == name) ||- (case lookupPkg db dN of- Nothing -> False- Just p -> V.withinRange (pkgVersion p) dVR)+checkAgainstDb db name dep =+ let dN = Util.Dist.depName dep+ dVR = Util.Dist.depVersionRange dep+ in (dN == name) ||+ (case lookupPkg db dN of+ Nothing -> False+ Just p -> V.withinRange (pkgVersion p) dVR) readDb :: FilePath -> IO CblDB readDb fp = handle- (\ e -> if isDoesNotExistError e- then return emptyPkgDB- else throwIO e)- $ do- r <- (mapM decode . C.lines) `liftM` C.readFile fp- case r of- Just a -> return a- Nothing -> fail "JSON parsing failed"+ (\ e -> if isDoesNotExistError e+ then return emptyPkgDB+ else throwIO e)+ $ do r <- (mapM decode . C.lines) `liftM` C.readFile fp+ case r of+ Just a -> return a+ Nothing -> fail "JSON parsing failed" saveDb :: CblDB -> FilePath -> IO () saveDb db fp = C.writeFile fp s- where- s = C.unlines $ map encode $ sort db---- {{{1 JSON instances--- $(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.Version)-instance ToJSON V.Version where- toJSON = toJSON . DV.showVersion- toEncoding = toEncoding . DV.showVersion--instance FromJSON V.Version where- parseJSON = withText "Version" $ go . readP_to_S DV.parseVersion . unpack- where- go [(v,[])] = return v- go (_ : xs) = go xs- go _ = fail $ "could not parse Version"--$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.VersionRange)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''FlagName)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''GhcPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''DistroPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''RepoPkgD)-$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg)--instance ToJSON P.Dependency where- toJSON (P.Dependency pn vr) = toJSON (P.unPackageName pn, vr)--instance FromJSON P.Dependency where- parseJSON v = do- (pn, vr) <- parseJSON v- return $ P.Dependency (P.PackageName pn) vr+ where+ s = C.unlines $ map encode $ sort db
+ src/PkgTypes.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++{-+ - Copyright 2011-2015 Per Magnus Therning+ -+ - Licensed under the Apache License, Version 2.0 (the "License");+ - you may not use this file except in compliance with the License.+ - You may obtain a copy of the License at+ -+ - http://www.apache.org/licenses/LICENSE-2.0+ -+ - Unless required by applicable law or agreed to in writing, software+ - distributed under the License is distributed on an "AS IS" BASIS,+ - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ - See the License for the specific language governing permissions and+ - limitations under the License.+ -}++module PkgTypes where++import Control.Applicative+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.TH (deriveJSON)+import Data.Text (unpack)+import qualified Data.Version as DV+import qualified Distribution.Package as P+import Distribution.PackageDescription+import qualified Distribution.Version as V+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Data.Vector as Vec++data Pkg = GhcPkg GhcPkgD+ | DistroPkg DistroPkgD+ | RepoPkg RepoPkgD+ deriving (Eq, Show)++data GhcPkgD = GhcPkgD { gpVersion :: V.Version }+ deriving (Eq, Show)++data DistroPkgD = DistroPkgD+ { dpVersion :: V.Version+ , dpXrev :: Int+ , dpRelease :: Int+ } deriving (Eq, Show)++data RepoPkgD = RepoPkgD+ { rpVersion :: V.Version+ , rpXrev :: Int+ , rpDeps :: [P.Dependency]+ , rpFlags :: FlagAssignment+ , rpRelease :: Int+ } deriving (Eq, Show)++data CblPkg = CP String Pkg+ deriving (Eq, Show)++type CblDB = [CblPkg]++instance Ord CblPkg where+ compare (CP n1 (GhcPkg d1)) (CP n2 (GhcPkg d2)) =+ compare (n1, gpVersion d1) (n2, gpVersion d2)+ compare (CP _ GhcPkg {}) _ = LT+ compare _ (CP _ GhcPkg {}) = GT++ compare (CP n1 (DistroPkg d1)) (CP n2 (DistroPkg d2)) =+ compare (n1, dpVersion d1, dpRelease d1) (n2, dpVersion d2, dpRelease d2)+ compare (CP _ DistroPkg {}) _ = LT+ compare _ (CP _ DistroPkg {}) = GT++ compare (CP n1 (RepoPkg d1)) (CP n2 (RepoPkg d2)) =+ compare (n1, rpVersion d1, rpRelease d1) (n2, rpVersion d2, rpRelease d2)++-- JSON instances+version2Json :: V.Version -> Value+version2Json = toJSON . DV.showVersion++json2Version :: Value -> Parser V.Version+json2Version = withText "Version" $ go . readP_to_S DV.parseVersion . unpack+ where+ go [(v,[])] = return v+ go (_ : xs) = go xs+ go _ = fail "could not parse Version"++dependencyList2Json :: [P.Dependency] -> Value+dependencyList2Json = toJSON . map convDep+ where+ convDep (P.Dependency (P.PackageName n) vr)= (n, versionRange2Json vr)++json2DependencyList :: Value -> Parser [P.Dependency]+json2DependencyList = withArray "DependencyList" parseList+ where+ parseList = mapM (withArray "Dependency" parseDep) . Vec.toList++ parseDep a = do+ n <- withText "PackageName" (return . unpack) (a Vec.! 0)+ vr <- json2VersionRange (a Vec.! 1)+ return $ P.Dependency (P.PackageName n) vr++versionRange2Json :: V.VersionRange -> Value+versionRange2Json = V.foldVersionRange+ (object ["AnyVersion" .= ([]::[(Int,Int)])])+ (\ v -> object ["ThisVersion" .= version2Json v])+ (\ v -> object ["LaterVersion" .= version2Json v])+ (\ v -> object ["EarlierVersion" .= version2Json v])+ (\ vr0 vr1 -> object ["UnionVersionRanges" .= [vr0, vr1]])+ (\ vr0 vr1 -> object ["IntersectVersionRanges" .= [vr0, vr1]])++json2VersionRange :: Value -> Parser V.VersionRange+json2VersionRange = withObject "VersionRange" go+ where+ go :: Object -> Parser V.VersionRange+ go o =+ V.thisVersion <$> (o .: "ThisVersion" >>= json2Version) <|>+ V.laterVersion <$> (o .: "LaterVersion" >>= json2Version) <|>+ V.earlierVersion <$> (o .: "EarlierVersion" >>= json2Version) <|>+ V.WildcardVersion <$> (o .: "WildcardVersion" >>= json2Version) <|>+ nullaryOp V.anyVersion <$> o .: "AnyVersion" <|>+ (o .: "UnionVersionRanges" >>= parserPair V.unionVersionRanges) <|>+ (o .: "IntersectVersionRanges" >>= parserPair V.intersectVersionRanges) <|>+ V.VersionRangeParens <$> (o .: "VersionRangeParens" >>= json2VersionRange)++ nullaryOp :: a -> Value -> a+ nullaryOp = const++ parserPair :: (V.VersionRange -> V.VersionRange -> V.VersionRange) -> Value -> Parser V.VersionRange+ parserPair f = withArray "parserPair" p+ where+ p a = do+ v1 <- json2VersionRange (a Vec.! 0)+ v2 <- json2VersionRange (a Vec.! 1)+ return $ f v1 v2++flagAssignment2Json :: FlagAssignment -> Value+flagAssignment2Json = toJSON . map convFlag+ where+ convFlag (FlagName s, b) = (s, b)++json2FlagAssignment :: Value -> Parser FlagAssignment+json2FlagAssignment = withArray "FlagAssignment" parseList+ where+ parseList = mapM (withArray "SingleFlag" parseFlag) . Vec.toList++ parseFlag a = do+ n <- withText "FlagName" (return . unpack) (a Vec.! 0)+ b <- withBool "FlagBool" return (a Vec.! 1)+ return (FlagName n, b)++instance ToJSON GhcPkgD where+ toJSON (GhcPkgD v) = object ["gpVersion" .= version2Json v]++instance FromJSON GhcPkgD where+ parseJSON = withObject "GhcPkgD" (\ o -> GhcPkgD <$> (o .: "gpVersion" >>= json2Version))++instance ToJSON DistroPkgD where+ toJSON (DistroPkgD v x r)= object [ "dpVersion" .= version2Json v+ , "dpXrev" .= x+ , "dpRelease" .= r+ ]++instance FromJSON DistroPkgD where+ parseJSON = withObject "DistroPkgD" go+ where+ go o = do+ v <- o .: "dpVersion" >>= json2Version+ x <- o .: "dpXrev"+ r <- o .: "dpRelease"+ return $ DistroPkgD v x r++instance ToJSON RepoPkgD where+ toJSON (RepoPkgD v x ds fs r)= object [ "rpVersion" .= version2Json v+ , "rpXrev" .= x+ , "rpDeps" .= dependencyList2Json ds+ , "rpFlags" .= flagAssignment2Json fs+ , "rpRelease" .= r+ ]++instance FromJSON RepoPkgD where+ parseJSON = withObject "RepoPkgD" go+ where+ go o = do+ v <- o .: "rpVersion" >>= json2Version+ x <- o .: "rpXrev"+ ds <- o .: "rpDeps" >>= json2DependencyList+ fs <- o .: "rpFlags" >>= json2FlagAssignment+ r <- o .: "rpRelease"+ return $ RepoPkgD v x ds fs r++$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg)+$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg)
src/Util/Misc.hs view
@@ -57,7 +57,7 @@ dbName = progName ++ ".db" ghcDefVersion = Version [7, 10, 3] []-ghcDefRelease = 2 :: Int+ghcDefRelease = 3 :: Int ghcVersionDep :: Version -> Int -> String ghcVersionDep ghcVer ghcRel = "ghc=" ++ display ghcVer ++ "-" ++ show ghcRel