diff --git a/app/Main.hs b/app/Main.hs index 0af92c0..5f653ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,31 +1,27 @@ {-# LANGUAGE ApplicativeDo #-} module Main where -import Control.Applicative ((<|>)) -import Data.Aeson (encode) -import Data.Bool (bool) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV +import Data.Aeson (encode) +import Data.Bool (bool) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Csv as CSV import Data.Foldable -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Data.Tree.View (drawTree) -import Options.Applicative (Parser, argument, command, - customExecParser, fullDesc, help, helper, - hsubparser, info, long, metavar, prefs, - progDesc, short, showDefault, - showHelpOnError, some, str, strOption, - switch, value, (<**>)) -import System.IO (stdin) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Tree.View (drawTree) +import Options.Applicative +import System.IO (stdin) +import Text.Blaze.Renderer.Utf8 (renderMarkup) import Text.Regex.TDFA import Graphex import Graphex.Core import qualified Graphex.CSV +import Graphex.Diff import Main.Cabal data Command @@ -42,7 +38,7 @@ data Command deriving stock Show -data Options = GraphCmd GraphOptions | CabalCmd CabalOptions +data Options = GraphCmd GraphOptions | CabalCmd CabalOptions | DiffCmd DiffOptions deriving stock Show data GraphOptions = GraphOptions { @@ -55,6 +51,7 @@ options :: Parser Options options = hsubparser $ fold [ command "graph" (info (GraphCmd <$> graphOptions) (progDesc "Graph operations")) , command "cabal" (info (CabalCmd <$> cabalOptions) (progDesc "Cabal operations")) + , command "diff" (info (DiffCmd <$> diffOptions) (progDesc "Diff operations")) ] graphOptions :: Parser GraphOptions @@ -85,6 +82,34 @@ graphOptions = GraphOptions removeCmd = Remove <$> switch (short 'r' <> help "Use regex") <*> some1 (argument str (metavar "module")) some1 = fmap NE.fromList . some +data DiffType = + DiffRanks + | DiffReverseRanks + deriving stock (Show) +data DiffOptions = DiffOptions + { graph1 :: FilePath + , graph2 :: FilePath + , format :: DiffFormat + } + deriving stock (Show) + +data DiffFormat = + DiffText + | DiffHtml + deriving stock (Show) + +readDiffFormat :: ReadM DiffFormat +readDiffFormat = eitherReader $ \case + "text" -> Right DiffText + "html" -> Right DiffHtml + x -> Left $ "Unrecognized diff format: " ++ x + +diffOptions :: Parser DiffOptions +diffOptions = DiffOptions + <$> argument str (metavar "GRAPH") + <*> argument str (metavar "GRAPH") + <*> option readDiffFormat (long "format" <> short 'f') + printStrs :: Foldable f => f Text -> IO () printStrs = traverse_ TIO.putStrLn @@ -125,5 +150,13 @@ main = customExecParser (prefs showHelpOnError) opts >>= \case | otherwise -> (`elem` patterns) BL.putStr $ encode $ graphToDep $ filterNodes shouldRemove graph CabalCmd cabalOpts -> runCabal cabalOpts + DiffCmd DiffOptions{..} -> do + g1 <- getInput graph1 + g2 <- getInput graph2 + let Diff{..} = diff g1 g2 + case format of + DiffHtml -> BL.putStr $ renderMarkup $ diff2html Diff{..} + DiffText -> do + TIO.putStrLn $ diff2text Diff{..} where opts = info (options <**> helper) ( fullDesc <> progDesc "Graph CLI tool.") diff --git a/package.yaml b/package.yaml index 1efd880..cb237cc 100644 --- a/package.yaml +++ b/package.yaml @@ -40,11 +40,15 @@ dependencies: - these - regex-tdfa - stm +- blaze-markup +- blaze-html +- hable library: source-dirs: src ghc-options: - -Wall + - -Werror=incomplete-patterns default-extensions: - OverloadedStrings @@ -53,6 +57,7 @@ default-extensions: - DerivingStrategies - DeriveAnyClass - DeriveGeneric + - DeriveFoldable - GeneralizedNewtypeDeriving - ViewPatterns - TupleSections @@ -76,6 +81,7 @@ executables: - -rtsopts - -with-rtsopts=-N - -Wall + - -Werror=incomplete-patterns dependencies: - graphex @@ -87,6 +93,8 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N + - -Wall + - -Werror=incomplete-patterns dependencies: - graphex - HUnit diff --git a/src/Graphex/Diff.hs b/src/Graphex/Diff.hs new file mode 100644 index 0000000..be6e80a --- /dev/null +++ b/src/Graphex/Diff.hs @@ -0,0 +1,89 @@ +module Graphex.Diff where + +import Control.Arrow (second) +import Control.Parallel.Strategies (NFData) +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid (Sum (..)) +import Data.Ord (Down (..)) +import Data.Semialign +import Data.Text (Text) +import qualified Data.Text as T +import Data.Tuple (swap) +import Hable +import Prelude hiding (div) +import Text.Blaze.Html5 + +import Graphex + +data Diff a = Diff + { netNodes :: Int + , nodes :: Map a Int + + , netReversedNodes :: Int + , reversedNodes :: Map a Int + } deriving stock (Show) + +diff :: NFData a => Ord a => Graph a -> Graph a -> Diff a +diff g1 g2 = Diff{..} + where + g1rev = reverseEdges g1 + g2rev = reverseEdges g2 + + r1 = rankings g1 + r2 = rankings g2 + + r1rev = rankings g1rev + r2rev = rankings g2rev + + doDiff x y = + let x' = Map.fromList $ fmap (second (Sum . negate) . swap) x + y' = Map.fromList $ fmap (second Sum . swap) y + in Map.filter (/= 0) $ Map.map getSum $ salign x' y' + + nodes = doDiff r1 r2 + netNodes = sum nodes + + reversedNodes = doDiff r1rev r2rev + netReversedNodes = sum reversedNodes + +diffFoldFor :: Ord a => Monoid b => (Diff a -> Map a Int) -> Diff a -> ((a, Int) -> b) -> b +diffFoldFor getter d = flip foldMap (sortOn (Down . abs . snd) $ Map.toList $ getter d) + +diff2html :: Diff Text -> Html +diff2html d = mconcat + [ div $ mconcat + [ "Net change in transitive import dependencies: ", toHtml (netNodes d) + , details $ table $ mconcat + [ tr $ mconcat + [ th "Module", th "Change" ] + , diffFoldFor nodes d $ \(m, net) -> + tr $ mconcat + [ td $ toHtml m, td $ toHtml net ] + ] + ] + , div $ mconcat + [ "Net change in reverse transitive import dependencies: ", toHtml (netReversedNodes d) + , details $ table $ mconcat + [ tr $ mconcat + [ th "Module", th "Change" ] + , diffFoldFor reversedNodes d $ \(m, net) -> + tr $ mconcat + [ td $ toHtml m, td $ toHtml net ] + ] + ] + ] + +diff2text :: Diff Text -> Text +diff2text d = T.pack $ unlines + [ unwords ["Net change in transitive import dependencies:", show (netNodes d)] + , hable defaultConfig $ (diffHeader :) $ diffFoldFor nodes d $ \(m, net) -> + [[T.unpack m, show net]] + , unwords ["Net change in reverse transitive import dependencies:", show (netReversedNodes d)] + , hable defaultConfig $ (diffHeader :) $ diffFoldFor reversedNodes d $ \(m, net) -> + [[T.unpack m, show net]] + ] + +diffHeader :: [String] +diffHeader = ["Module", "Change"] diff --git a/stack.yaml b/stack.yaml index c44de8e..85de87e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -66,3 +66,6 @@ extra-deps: [] # compiler-check: newer-minor nix: packages: [zlib] + +extra-deps: +- hable-0.3.1 diff --git a/test/CabalSpec.hs b/test/CabalSpec.hs index a345484..e5d36a2 100644 --- a/test/CabalSpec.hs +++ b/test/CabalSpec.hs @@ -26,6 +26,7 @@ libModules = , Module "Graphex.Search" "src/Graphex/Search.hs" , Module "Graphex.Logger" "src/Graphex/Logger.hs" , Module "Graphex.Queue" "src/Graphex/Queue.hs" + , Module "Graphex.Diff" "src/Graphex/Diff.hs" ] searchModuleGraph :: ModuleGraph