Restrict a dot graph to a subposet.

subposet-dot.hs

#!/usr/bin/env nix-shell
#!nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [ graphviz topograph ])"
{-
A simple script that reads a dot graph from standard input, restricts
it to the *subposet* on the labels given as arguments (that is, computes
the transitive reduction of a subgraph of its transitive closure) and
prints the result to standard output.

Node and edge labels are destroyed, and the output graph uses input
labels as node IDs.
-}
{-# LANGUAGE RecordWildCards #-}
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import Data.Map (Map)
import Data.Map qualified as M
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as T
import Data.Text.Lazy.IO qualified as T
import System.Environment
import Topograph

runGOrExplode :: (Show v, Ord v) => (forall i. Ord i => G v i -> r) -> Map v (Set v) -> r
runGOrExplode f g = case runG g f of
  Left c -> error ("cycle detected: " <> show c)
  Right x -> x

subgraph :: Ord v => Set v -> Map v (Set v) -> Map v (Set v)
subgraph subset g = fmap (S.intersection subset) (M.restrictKeys g subset)

subposet :: (Show v, Ord v) => Set v -> Map v (Set v) -> Map v (Set v)
subposet subset = runGOrExplode (adjacencyMap . reduction) . subgraph subset . runGOrExplode (adjacencyMap . closure)

main = do
  subset <- S.fromList . map T.pack <$> getArgs
  dotIn@DotGraph{graphStatements=grStmts@DotStmts{nodeStmts, edgeStmts}} :: DotGraph Text <- parseDotGraph <$> T.getContents
  let
    nodes = M.fromList [(id, label) | DotNode{nodeID = id, nodeAttributes} <- nodeStmts, Label (StrLabel label) <- nodeAttributes]
    graphIn = M.fromListWith (<>) [(nodes M.! from, S.singleton (nodes M.! to)) | DotEdge from to _ <- edgeStmts]
    graphOut = subposet subset graphIn
    dotOut = dotIn {graphStatements = grStmts { nodeStmts = [DotNode l [] | l <- S.toList subset], edgeStmts = [DotEdge from to [] | (from, adj) <- M.assocs graphOut, to <- S.toList adj] }}
  T.putStrLn (printDotGraph dotOut)