bin/track_haskell_deps.hs

   1 #!/usr/bin/env stack
   2 -- stack runghc --package shelly --package algebraic-graphs --package async
   3
   4 {-
   5
   6 It's warmly recommended to compile this script as a binary, in order to exploit multicore
   7 parallelism, e.g.:
   8
   9 stack exec ghc -- --make -O2 -threaded scripts/haskell/dependencies.hs
  10 ./dependencies +RTS -N
  11
  12 -}
  13
  14 {-# LANGUAGE BangPatterns        #-}
  15 {-# LANGUAGE OverloadedStrings   #-}
  16 {-# LANGUAGE RankNTypes          #-}
  17 {-# LANGUAGE ScopedTypeVariables #-}
  18 {-# LANGUAGE TupleSections       #-}
  19 {-# LANGUAGE NumericUnderscores  #-}
  20 {-# LANGUAGE ViewPatterns        #-}
  21
  22 module Main where
  23
  24 import           Algebra.Graph
  25 import           Algebra.Graph.Export.Dot (Attribute (..), Style (..), export)
  26 import           Control.Concurrent.Async (mapConcurrently)
  27 import           Control.Concurrent
  28 import           Control.Exception
  29 import           Control.Monad
  30 import           Data.Functor.Identity
  31 import           Data.List
  32 import qualified Data.Map.Strict          as M
  33 import           Data.Monoid
  34 import qualified Data.Set                 as Set
  35 import qualified Data.Text                as T
  36 import           Shelly
  37 import           System.IO
  38 import           Text.Printf
  39 import           Text.Read
  40
  41
  42 --------------------------------------------------------------------------------
  43 type PackageName = T.Text
  44
  45 data Version = V [Int] deriving (Eq, Ord)
  46
  47 type Package = (PackageName, Version)
  48
  49 type DAG       = Graph Package
  50
  51 type DepMap    = M.Map Package [Package]
  52
  53 type RevDepMap = M.Map Package [Package]
  54
  55 --------------------------------------------------------------------------------
  56 readVersionM :: Monad m => (String -> m Int) -> T.Text -> m Version
  57 readVersionM f = fmap V . sequence . map (f . T.unpack) . T.splitOn "."
  58
  59 --------------------------------------------------------------------------------
  60 readVersionMaybe :: T.Text -> Maybe Version
  61 readVersionMaybe = readVersionM readMaybe
  62
  63 --------------------------------------------------------------------------------
  64 readVersion :: T.Text -> Version
  65 readVersion = runIdentity . readVersionM (liftM read . pure)
  66
  67 logScreen :: MVar () -> String -> IO ()
  68 logScreen screenLock msg = do
  69   () <- takeMVar screenLock
  70   putStrLn msg
  71   putMVar screenLock ()
  72
  73 --------------------------------------------------------------------------------
  74 mkPackage :: T.Text -> Package
  75 mkPackage t = case T.splitOn " " (T.strip t) of
  76     [name, ver] -> (name, readVersion ver)
  77     _           -> case T.breakOnEnd "-" (T.strip t) of
  78         ("", _)     -> error $ "mkPackage: " <> show t
  79         (name, ver) -> (T.init name, readVersion ver)
  80
  81 --------------------------------------------------------------------------------
  82 blacklistedPackages :: [T.Text]
  83 blacklistedPackages = []
  84
  85 --------------------------------------------------------------------------------
  86 -- Filter blacklisted packages if they cannot be found by `ghc-pkg`, for some reason.
  87 getTotalPackages :: IO [Package]
  88 getTotalPackages = do
  89     rawList <- shelly $ silently $ run "stack" ["--nix", "ls", "dependencies", "--test", "--bench"]
  90     return $ map mkPackage (filter (not . blacklisted) (T.lines rawList))
  91     where
  92       blacklisted x = or $ map (flip T.isInfixOf x) blacklistedPackages
  93
  94 --------------------------------------------------------------------------------
  95 directDependenciesFor :: MVar () -> Package -> IO [Package]
  96 directDependenciesFor screenLock (name, ver) = do
  97     res <- try $ shelly $ silently $ run "stack" ["--nix", "exec", "ghc-pkg", "field", name, "depends"]
  98     case res of
  99       Left (err :: SomeException) -> do
 100         logScreen screenLock $ "Got: " <> show err
 101         logScreen screenLock "Skipping package..."
 102         pure mempty
 103       Right rawOutput ->
 104         case concatMap (T.words . T.replace "depends:" mempty . T.strip) (dropWhile (\l -> not ("depends:" `T.isInfixOf` l)) $ T.lines rawOutput) of
 105           deps -> do
 106               logScreen screenLock $ "Found " <> show (length deps) <> " deps for " <> show name
 107               let !normalised = concatMap (map (mkPackage . normalisePackage) . T.splitOn " ") (takeWhile (/= "depends:") deps)
 108               pure $! normalised
 109
 110 --------------------------------------------------------------------------------
 111 buildPackageMap :: forall m. Monad m => (Package -> m [Package]) -> [Package] -> m DepMap
 112 buildPackageMap _ [] = return M.empty
 113 buildPackageMap f pkgs = go pkgs M.empty
 114   where
 115     go :: [Package] -> DepMap -> m DepMap
 116     go [] depMap = return depMap
 117     go (pkg:xs) depMap = do
 118       directDeps <- f pkg
 119       let !newMap = M.insert pkg directDeps $! depMap
 120       go xs newMap
 121
 122 --------------------------------------------------------------------------------
 123 buildDependencyMap :: [Package] -> IO DepMap
 124 buildDependencyMap allDeps = do
 125     screenLock <- newEmptyMVar
 126     putMVar screenLock ()
 127     mapAsList <- mapConcurrently (\pkg -> (pkg,) <$> directDependenciesFor screenLock pkg) allDeps
 128     return $ M.fromList mapAsList
 129
 130 --------------------------------------------------------------------------------
 131 buildReverseDependencyMap :: [Package] -> DepMap -> RevDepMap
 132 buildReverseDependencyMap allDeps depMap =
 133     runIdentity $ buildPackageMap (Identity . reverseDependenciesFor allDeps depMap) allDeps
 134
 135 --------------------------------------------------------------------------------
 136 buildUniqueDependencyMap :: [Package] -> DepMap -> RevDepMap -> DepMap
 137 buildUniqueDependencyMap allDeps depMap revMap =
 138     runIdentity $ buildPackageMap (Identity . uniqueDependenciesFor depMap revMap) allDeps
 139
 140 --------------------------------------------------------------------------------
 141 buildDependencyDAG :: [Package] -> DepMap -> IO DAG
 142 buildDependencyDAG allPkgs depMap = go allPkgs Set.empty
 143   where
 144     go :: [Package] -> Set.Set (Package, Package) -> IO DAG
 145     go [] dagEdges = return . edges . Set.toList $ dagEdges
 146     go (pkg:xs) dagEdges = do
 147       let directDeps   = M.findWithDefault mempty pkg depMap
 148       let !newDag = dagEdges <> Set.fromList (map (pkg,) directDeps)
 149       go xs newDag
 150
 151 --------------------------------------------------------------------------------
 152 -- | >>> normalisePackage "conduit-1.2.10-GgLn1U1QYcf9wsQecuZ1A4"
 153 -- "conduit-1.2.10"
 154 -- >>> normalisePackage "conduit-1.2.10"
 155 -- "conduit-1.2.10"
 156 normalisePackage :: T.Text -> T.Text
 157 normalisePackage "rts" = "rts-0.0.0.0"
 158 normalisePackage txt = case T.breakOnEnd "-" txt of
 159     (x, xs) -> case readVersionMaybe xs of
 160         Just _  -> txt
 161         Nothing -> if x == "" then error ("normalisePackage: " <> show txt) else T.init x
 162
 163
 164 --------------------------------------------------------------------------------
 165 unavoidableDeps :: Package -> Package -> Bool
 166 unavoidableDeps myself x = and [
 167       x /= myself
 168     , not ("gargantext" `T.isInfixOf` (fst x))
 169     ]
 170
 171 --------------------------------------------------------------------------------
 172 -- | Filter "unavoilable" dependencies like the ones of the gargantext family.
 173 reverseDependenciesFor :: [Package] -> DepMap -> Package -> [Package]
 174 reverseDependenciesFor allDeps directDeps pkg = go (filter (unavoidableDeps pkg) allDeps) mempty
 175   where
 176     go [] !revDeps     = revDeps
 177     go (x:xs) !revDeps = case reachableFrom x of
 178         True  -> go xs (x : revDeps)
 179         False -> go xs revDeps
 180         -- For each package x, check the graph to see if there is a path going
 181         -- from x to `pkg`. If there is, we found a reverse dep.
 182     reachableFrom :: Package -> Bool
 183     reachableFrom directDep =
 184         let depsForThis = M.findWithDefault mempty directDep directDeps
 185         in case pkg `elem` depsForThis of
 186             True  -> True
 187             False -> go depsForThis
 188       where
 189         go :: [Package] -> Bool
 190         go [] = False
 191         go xs = any reachableFrom xs
 192
 193 --------------------------------------------------------------------------------
 194 -- | Compute the "unique direct dependencies", which are the dependencies that
 195 -- only this package introduces into the project.
 196 -- In other terms, we need to count for each DIRECT dependency, the number of
 197 -- REVERSE dependencies. If it's one, and it's the package in question, it
 198 -- means that removing that dependency would also remove the associated package.
 199 uniqueDependenciesFor :: DepMap -> RevDepMap -> Package -> [Package]
 200 uniqueDependenciesFor directDeps revDeps pkg = go (M.findWithDefault mempty pkg directDeps) []
 201     where
 202       go [] !deps     = deps
 203       go (d:ds) !deps = case M.findWithDefault mempty d revDeps of
 204           [x] | x == pkg -> go ds (d : deps)
 205           _   -> go ds deps
 206
 207 --------------------------------------------------------------------------------
 208 style :: Style Package String
 209 style = Style
 210     { graphName               = ""
 211     , preamble                = mempty
 212     , graphAttributes         = ["label" := "Example", "labelloc" := "top"]
 213     , defaultVertexAttributes = ["shape" := "circle"]
 214     , defaultEdgeAttributes   = mempty
 215     , vertexName              = \(name,_)   -> T.unpack name
 216     , vertexAttributes        = \_   -> ["color" := "blue"]
 217     , edgeAttributes          = \_ _ -> ["style" := "dashed"]
 218     }
 219
 220 --------------------------------------------------------------------------------
 221 dottify :: DAG -> IO ()
 222 dottify dag = writeFile "dep_dot.graphviz" (export style dag)
 223
 224 --------------------------------------------------------------------------------
 225 main :: IO ()
 226 main = do
 227     hSetBuffering System.IO.stdout NoBuffering
 228     hSetBuffering System.IO.stderr NoBuffering
 229     allDeps <- getTotalPackages
 230     putStr "Building direct dependency map..."
 231     directDepMap  <- buildDependencyMap allDeps
 232     putStrLn "ok."
 233     let revDepMap    = buildReverseDependencyMap allDeps directDepMap
 234     let uniqueDepMap = buildUniqueDependencyMap allDeps directDepMap revDepMap
 235
 236     let tableHeader         =  printf "%-40s" ("Package" :: String)
 237                             <> printf "%-20s" ("Direct deps"  :: String)
 238                             <> printf "%-20s" ("Unique deps"  :: String)
 239                             <> printf "%-70s" ("Reverse deps"  :: String)
 240     let tableEntry pkg (totalDeps, uniqueDeps) revDeps =
 241                printf "%-40s" (T.unpack pkg)
 242             <> printf "%-20s" (show totalDeps)
 243             <> printf "%-20s" (show uniqueDeps)
 244             <> printf "%-70s\n" (T.unpack $ showRevDeps revDeps)
 245     putStrLn tableHeader
 246
 247     let depsMap = M.map length directDepMap
 248     let sortedDepList = reverse (sortOn snd $ M.toList depsMap)
 249
 250     let mkTableEntry  (pkg@(pkgName,_), deps) =
 251             let revDeps    = M.findWithDefault mempty pkg revDepMap
 252                 uniqueDeps = M.findWithDefault mempty pkg uniqueDepMap
 253             in tableEntry pkgName (deps, length uniqueDeps) revDeps
 254
 255     forM_ sortedDepList (putStr . mkTableEntry)
 256
 257     -- Display the total deps
 258     putStrLn $ "Total project deps: " <> (show $ length allDeps + length blacklistedPackages)
 259
 260 showRevDeps :: [Package] -> T.Text
 261 showRevDeps []  = T.pack $ printf "%-4d%s" (0 :: Int) ("(possibly gargantext depends on it)" :: String)
 262 showRevDeps [(pkgName,_)] = T.pack $ printf "%-4d%s" (1 :: Int) ("(" <> T.unpack pkgName <> ")")
 263 showRevDeps xs
 264   | length xs <= 5 = T.pack $ printf "%-4d%s" (length xs) (T.unpack $ "(" <> T.intercalate "," (map fst xs) <> ")")
 265   | otherwise      = T.pack $ printf "%-4d%s" (length xs) (T.unpack $ "(" <> T.intercalate "," (map fst (take 5 xs)) <> ",...)")