hackage-meta: some scripts for filling out missing bounds

2016-10-30 22:45:44 +01:00
parent 27feb31e18
commit 3bb2e26b4d
4 changed files with 157 additions and 0 deletions
--- a/scripts/bounds.hs
+++ b/scripts/bounds.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE LambdaCase #-}
+import Control.Arrow
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import Data.Function
+import Data.Map (Map)
+import qualified Data.Map as M
+import System.Environment
+import System.FilePath
+import System.Directory
+
+import Distribution.Verbosity
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import Distribution.PackageDescription
+import Distribution.Package
+import Distribution.Version
+import Distribution.Text
+import Text.PrettyPrint
+import System.Environment
+
+
+datadir = "hackage-metadata"
+
+main = do
+  [pkg,v] <- getArgs
+
+  let pkg_id = pkg ++ "-" ++ v
+      cabal_file = datadir </> pkg_id <.> "cabal"
+
+  pkg_time <- getTime pkg v
+
+  ps <-
+      mapMaybe (\case (p, "-any") -> Just p
+                      _ -> Nothing)
+
+                  <$> getDeps cabal_file
+  vs <- mapM (getClosestVersion pkg_time) ps
+  print $ ps `zip` vs
+  return ()
+
+check :: VersionRange -> Version -> Bool
+check vr v = withinRange v vr
+
+getClosestVersion :: Integer -> String -> IO String
+getClosestVersion pkg_time dep = do
+  vs <- getVersions dep
+  ts <- mapM (getTime dep) vs
+  let vtalist = sortBy (flip compare `on` snd) $ vs `zip` ts
+      ((v,_t):_) = filter ((<pkg_time) . snd) vtalist
+--      Just v' = simpleParse v
+  return v
+
+getVersions :: String -> IO [String]
+getVersions p = do
+  fs <- listDirectory datadir
+  return $ nub
+         $ map snd
+         $ filter ((==p) . fst)
+         $ map (parsePkgId . dropExtension)
+         $ filter (p `isPrefixOf`) fs
+
+getTime :: String -> String -> IO Integer
+getTime p v = do
+  let pkg_id = p ++ "-" ++ v
+      file = datadir </> pkg_id <.> "upload-date"
+  read <$> readFile file
+
+getDeps f = do
+  pd <- flattenPackageDescription <$> readPackageDescription silent f
+  return $ --nubBy ((==) `on` fst) $
+             [ (unPackageName n, (render . disp) v)
+             | (Dependency n v) <- buildDepends pd
+             , not $ unPackageName n `elem` [
+                    "ghc-mod",
+                    "ghc",
+                    "array",
+                    "base",
+                    "bin-package-db",
+                    "binary",
+                    "bytestring",
+                    "containers",
+                    "deepseq",
+                    "directory",
+                    "filepath",
+                    "ghc-binary",
+                    "ghc-boot",
+                    "ghc-boot-th",
+                    "ghc-prim",
+                    "ghci",
+                    "haskelline",
+                    "haskell2010",
+                    "haskell98",
+                    "haskell98",
+                    "hoopl",
+                    "hpc",
+                    "integer-gmp",
+                    "old-locale",
+                    "old-time",
+                    "pretty",
+                    "process",
+                    "random",
+                    "rts",
+                    "template-haskell",
+                    "terminfo",
+                    "time",
+                    "transformers",
+                    "unix",
+                    "xhtml"
+                   ]
+             ]
+
+parsePkgId pkg_id = let
+    v:pkgcs = reverse $ splitOn "-" pkg_id
+  in
+    (intercalate "-" $ reverse pkgcs, v)