hackage-meta: some scripts for filling out missing bounds

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)

scripts/diff.hs

@@ -0,0 +1,11 @@
+import Data.Tuple
+import System.FilePath
+import System.Environment
+import System.Process
+
+main = do
+  vs <- lines <$> getContents
+  [pkg, dir] <- getArgs
+  mapM_ system $ map (\(v1, v2) -> "diff -u --color=always " ++ file pkg dir v1 ++ " " ++ file pkg dir v2 ++ "; echo; echo; echo") $ map swap $ drop 1 vs `zip` vs
+ where
+   file pkg dir v = dir </> (pkg ++ "-" ++ v) <.> "cabal"

scripts/edit-bounds-macros.el

@@ -0,0 +1,16 @@
+
+(fset 'goto-lib-dep
+   (lambda (&optional arg) "Keyboard macro." (interactive "p") (kmacro-exec-ring-item (quote ([134217788 21 19 94 108 105 98 114 97 114 121 13 19 98 117 105 108 100 45 100 101 112 101 110 100 115 58 13 19 44 32 25 13 18 44 13 6 6] 0 "%d")) arg)))
+
+
+(fset 'copy-dep-name
+   (lambda (&optional arg) "Keyboard macro." (interactive "p") (kmacro-exec-ring-item (quote ([1 19 44 32 return 67108896 134217830 134217847 24 24 67108896 67108896] 0 "%d")) arg)))
+
+(fset 'replace-with-lib-dep
+   [?\C-a ?\M-x ?c ?o ?p ?y ?- ?d ?e ?p ?- ?n ?a ?m ?e ?\C-m ?\C-x ?r ?  ?r ?\M-x ?g ?o ?t ?o ?- ?l ?i ?b ?- ?d ?e ?p ?\C-m ?\C-  ?\C-e ?\M-w ?\C-x ?r ?j ?r ?\C-y ?\C-k ?\C-x ?\C-x ?\C-  ?\C- ])
+
+(fset 'yank-kill-replace
+   [?\C-  ?\C-  ?\C-y ?\C-k ?\C-x ?\C-x ?\M-w])
+
+(global-set-key (kbd "C-c C-r") 'replace-with-lib-dep)
+(global-set-key (kbd "C-c C-k") 'yank-kill-replace)

scripts/extract-build-deps.hs

@@ -0,0 +1,13 @@
+import Distribution.Verbosity
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import Distribution.PackageDescription
+import Distribution.Package
+import Distribution.Text
+import Text.PrettyPrint
+import System.Environment
+
+main = do
+  [f] <- getArgs
+  pd <- flattenPackageDescription <$> readPackageDescription silent f
+  mapM_ putStrLn $ map (\(Dependency n v) -> unPackageName n ++ "\t" ++ render (disp v)) $ buildDepends pd