{-# OPTIONS_GHC -Wunused-imports #-}

module Agda.Interaction.Highlighting.Dot.Backend
  ( dotBackend
  ) where

import Agda.Interaction.Highlighting.Dot.Base (renderDotToFile)

import Control.Monad.Except
  ( ExceptT
  , runExceptT
  , MonadError(throwError)
  )
import Control.Monad.IO.Class
  ( MonadIO(..)
  )
import Control.DeepSeq

import Data.HashSet (HashSet)
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.HashSet as HashSet
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import qualified Data.Text.Lazy as L

import GHC.Generics (Generic)

import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..))
import Agda.Compiler.Common (curIF, IsMain)

import Agda.Interaction.FindFile (findFile, srcFilePath)
import Agda.Interaction.Library
import Agda.Interaction.Options
  ( ArgDescr(ReqArg)
  , Flag
  , OptDescr(..)
  )

import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)

import Agda.TypeChecking.Monad
  ( Interface(iImportedModules)
  , MonadTCError
  , ReadTCState
  , MonadTCM(..)
  , genericError
  , reportSDoc
  , getAgdaLibFiles
  )
import Agda.TypeChecking.Pretty

import Agda.Utils.Graph.AdjacencyMap.Unidirectional
  (Graph, WithUniqueInt)
import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph
import Agda.Syntax.Common.Pretty ( prettyShow )

-- ------------------------------------------------------------------------

data DotFlags = DotFlags
  { DotFlags -> Maybe String
dotFlagDestination :: Maybe FilePath
  , DotFlags -> Maybe (HashSet String)
dotFlagLibraries   :: Maybe (HashSet String)
    -- ^ Only include modules from the given libraries.
  } deriving (DotFlags -> DotFlags -> Bool
(DotFlags -> DotFlags -> Bool)
-> (DotFlags -> DotFlags -> Bool) -> Eq DotFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DotFlags -> DotFlags -> Bool
== :: DotFlags -> DotFlags -> Bool
$c/= :: DotFlags -> DotFlags -> Bool
/= :: DotFlags -> DotFlags -> Bool
Eq, (forall x. DotFlags -> Rep DotFlags x)
-> (forall x. Rep DotFlags x -> DotFlags) -> Generic DotFlags
forall x. Rep DotFlags x -> DotFlags
forall x. DotFlags -> Rep DotFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DotFlags -> Rep DotFlags x
from :: forall x. DotFlags -> Rep DotFlags x
$cto :: forall x. Rep DotFlags x -> DotFlags
to :: forall x. Rep DotFlags x -> DotFlags
Generic)

instance NFData DotFlags

defaultDotFlags :: DotFlags
defaultDotFlags :: DotFlags
defaultDotFlags = DotFlags
  { dotFlagDestination :: Maybe String
dotFlagDestination = Maybe String
forall a. Maybe a
Nothing
  , dotFlagLibraries :: Maybe (HashSet String)
dotFlagLibraries   = Maybe (HashSet String)
forall a. Maybe a
Nothing
  }

dotFlagsDescriptions :: [OptDescr (Flag DotFlags)]
dotFlagsDescriptions :: [OptDescr (Flag DotFlags)]
dotFlagsDescriptions =
  [ String
-> [String]
-> ArgDescr (Flag DotFlags)
-> String
-> OptDescr (Flag DotFlags)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"dependency-graph"] ((String -> Flag DotFlags) -> String -> ArgDescr (Flag DotFlags)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag DotFlags
dependencyGraphFlag String
"FILE")
              String
"generate a Dot file with a module dependency graph"
  , String
-> [String]
-> ArgDescr (Flag DotFlags)
-> String
-> OptDescr (Flag DotFlags)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"dependency-graph-include"]
      ((String -> Flag DotFlags) -> String -> ArgDescr (Flag DotFlags)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag DotFlags
includeFlag String
"LIBRARY")
      String
"include modules from the given library (default: all modules)"
  ]

dependencyGraphFlag :: FilePath -> Flag DotFlags
dependencyGraphFlag :: String -> Flag DotFlags
dependencyGraphFlag String
f DotFlags
o = Flag DotFlags
forall a. a -> OptM a
forall (m :: * -> *) a. Monad m => a -> m a
return Flag DotFlags -> Flag DotFlags
forall a b. (a -> b) -> a -> b
$ DotFlags
o { dotFlagDestination = Just f }

includeFlag :: String -> Flag DotFlags
includeFlag :: String -> Flag DotFlags
includeFlag String
l DotFlags
o = Flag DotFlags
forall a. a -> OptM a
forall (m :: * -> *) a. Monad m => a -> m a
return Flag DotFlags -> Flag DotFlags
forall a b. (a -> b) -> a -> b
$
  DotFlags
o { dotFlagLibraries =
        case dotFlagLibraries o of
          Maybe (HashSet String)
Nothing -> HashSet String -> Maybe (HashSet String)
forall a. a -> Maybe a
Just (String -> HashSet String
forall a. Hashable a => a -> HashSet a
HashSet.singleton String
l)
          Just HashSet String
s  -> HashSet String -> Maybe (HashSet String)
forall a. a -> Maybe a
Just (String -> HashSet String -> HashSet String
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert String
l HashSet String
s)
    }

data DotCompileEnv = DotCompileEnv
  { DotCompileEnv -> String
dotCompileEnvDestination :: FilePath
  , DotCompileEnv -> Maybe (HashSet String)
dotCompileEnvLibraries   :: Maybe (HashSet String)
    -- ^ Only include modules from the given libraries.
  }

-- Currently unused
data DotModuleEnv = DotModuleEnv

data DotModule = DotModule
  { DotModule -> TopLevelModuleName
dotModuleName          :: TopLevelModuleName
  , DotModule -> Set TopLevelModuleName
dotModuleImportedNames :: Set TopLevelModuleName
  , DotModule -> Bool
dotModuleInclude       :: Bool
    -- ^ Include the module in the graph?
  }

-- | Currently unused
data DotDef = DotDef

dotBackend :: Backend
dotBackend :: Backend
dotBackend = Backend'_boot
  TCM DotFlags DotCompileEnv DotModuleEnv DotModule DotDef
-> Backend
forall opts (tcm :: * -> *) env menv mod def.
NFData opts =>
Backend'_boot tcm opts env menv mod def -> Backend_boot tcm
Backend Backend'_boot
  TCM DotFlags DotCompileEnv DotModuleEnv DotModule DotDef
dotBackend'

dotBackend' :: Backend' DotFlags DotCompileEnv DotModuleEnv DotModule DotDef
dotBackend' :: Backend'_boot
  TCM DotFlags DotCompileEnv DotModuleEnv DotModule DotDef
dotBackend' = Backend'
  { backendName :: String
backendName           = String
"Dot"
  , backendVersion :: Maybe String
backendVersion        = Maybe String
forall a. Maybe a
Nothing
  , options :: DotFlags
options               = DotFlags
defaultDotFlags
  , commandLineFlags :: [OptDescr (Flag DotFlags)]
commandLineFlags      = [OptDescr (Flag DotFlags)]
dotFlagsDescriptions
  , isEnabled :: DotFlags -> Bool
isEnabled             = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (DotFlags -> Maybe String) -> DotFlags -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotFlags -> Maybe String
dotFlagDestination
  , preCompile :: DotFlags -> TCM DotCompileEnv
preCompile            = ExceptT String TCM DotCompileEnv -> TCM DotCompileEnv
forall (m :: * -> *) b. MonadTCError m => ExceptT String m b -> m b
asTCErrors (ExceptT String TCM DotCompileEnv -> TCM DotCompileEnv)
-> (DotFlags -> ExceptT String TCM DotCompileEnv)
-> DotFlags
-> TCM DotCompileEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotFlags -> ExceptT String TCM DotCompileEnv
forall (m :: * -> *).
MonadError String m =>
DotFlags -> m DotCompileEnv
preCompileDot
  , preModule :: DotCompileEnv
-> IsMain
-> TopLevelModuleName
-> Maybe String
-> TCM (Recompile DotModuleEnv DotModule)
preModule             = DotCompileEnv
-> IsMain
-> TopLevelModuleName
-> Maybe String
-> TCM (Recompile DotModuleEnv DotModule)
forall (m :: * -> *).
Applicative m =>
DotCompileEnv
-> IsMain
-> TopLevelModuleName
-> Maybe String
-> m (Recompile DotModuleEnv DotModule)
preModuleDot
  , compileDef :: DotCompileEnv -> DotModuleEnv -> IsMain -> Definition -> TCM DotDef
compileDef            = DotCompileEnv -> DotModuleEnv -> IsMain -> Definition -> TCM DotDef
forall (m :: * -> *).
Applicative m =>
DotCompileEnv -> DotModuleEnv -> IsMain -> Definition -> m DotDef
compileDefDot
  , postModule :: DotCompileEnv
-> DotModuleEnv
-> IsMain
-> TopLevelModuleName
-> [DotDef]
-> TCM DotModule
postModule            = DotCompileEnv
-> DotModuleEnv
-> IsMain
-> TopLevelModuleName
-> [DotDef]
-> TCM DotModule
forall (m :: * -> *).
(MonadTCM m, ReadTCState m) =>
DotCompileEnv
-> DotModuleEnv
-> IsMain
-> TopLevelModuleName
-> [DotDef]
-> m DotModule
postModuleDot
  , postCompile :: DotCompileEnv
-> IsMain -> Map TopLevelModuleName DotModule -> TCM ()
postCompile           = DotCompileEnv
-> IsMain -> Map TopLevelModuleName DotModule -> TCM ()
forall (m :: * -> *).
(MonadIO m, ReadTCState m) =>
DotCompileEnv -> IsMain -> Map TopLevelModuleName DotModule -> m ()
postCompileDot
  , scopeCheckingSuffices :: Bool
scopeCheckingSuffices = Bool
True
  , mayEraseType :: QName -> TCM Bool
mayEraseType          = TCM Bool -> QName -> TCM Bool
forall a b. a -> b -> a
const (TCM Bool -> QName -> TCM Bool) -> TCM Bool -> QName -> TCM Bool
forall a b. (a -> b) -> a -> b
$ Bool -> TCM Bool
forall a. a -> TCM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  }

-- | Convert a general "MonadError String m" into "MonadTCError m".
asTCErrors :: MonadTCError m => ExceptT String m b -> m b
asTCErrors :: forall (m :: * -> *) b. MonadTCError m => ExceptT String m b -> m b
asTCErrors ExceptT String m b
t = (String -> m b) -> (b -> m b) -> Either String b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m b
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
String -> m a
genericError b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m b) -> m (Either String b) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT String m b -> m (Either String b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String m b
t

preCompileDot
  :: MonadError String m
  => DotFlags
  -> m DotCompileEnv
preCompileDot :: forall (m :: * -> *).
MonadError String m =>
DotFlags -> m DotCompileEnv
preCompileDot DotFlags
d = case DotFlags -> Maybe String
dotFlagDestination DotFlags
d of
  Just String
dest -> DotCompileEnv -> m DotCompileEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DotCompileEnv -> m DotCompileEnv)
-> DotCompileEnv -> m DotCompileEnv
forall a b. (a -> b) -> a -> b
$ DotCompileEnv
    { dotCompileEnvDestination :: String
dotCompileEnvDestination = String
dest
    , dotCompileEnvLibraries :: Maybe (HashSet String)
dotCompileEnvLibraries   = DotFlags -> Maybe (HashSet String)
dotFlagLibraries DotFlags
d
    }
  Maybe String
Nothing ->
    String -> m DotCompileEnv
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"The Dot backend was invoked without being enabled!"

preModuleDot
  :: Applicative m
  => DotCompileEnv
  -> IsMain
  -> TopLevelModuleName
  -> Maybe FilePath
  -> m (Recompile DotModuleEnv DotModule)
preModuleDot :: forall (m :: * -> *).
Applicative m =>
DotCompileEnv
-> IsMain
-> TopLevelModuleName
-> Maybe String
-> m (Recompile DotModuleEnv DotModule)
preModuleDot DotCompileEnv
_cenv IsMain
_main TopLevelModuleName
_moduleName Maybe String
_ifacePath = Recompile DotModuleEnv DotModule
-> m (Recompile DotModuleEnv DotModule)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Recompile DotModuleEnv DotModule
 -> m (Recompile DotModuleEnv DotModule))
-> Recompile DotModuleEnv DotModule
-> m (Recompile DotModuleEnv DotModule)
forall a b. (a -> b) -> a -> b
$ DotModuleEnv -> Recompile DotModuleEnv DotModule
forall menv mod. menv -> Recompile menv mod
Recompile DotModuleEnv
DotModuleEnv

compileDefDot
  :: Applicative m
  => DotCompileEnv
  -> DotModuleEnv
  -> IsMain
  -> Definition
  -> m DotDef
compileDefDot :: forall (m :: * -> *).
Applicative m =>
DotCompileEnv -> DotModuleEnv -> IsMain -> Definition -> m DotDef
compileDefDot DotCompileEnv
_cenv DotModuleEnv
_menv IsMain
_main Definition
_def = DotDef -> m DotDef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotDef
DotDef

postModuleDot
  :: (MonadTCM m, ReadTCState m)
  => DotCompileEnv
  -> DotModuleEnv
  -> IsMain
  -> TopLevelModuleName
  -> [DotDef]
  -> m DotModule
postModuleDot :: forall (m :: * -> *).
(MonadTCM m, ReadTCState m) =>
DotCompileEnv
-> DotModuleEnv
-> IsMain
-> TopLevelModuleName
-> [DotDef]
-> m DotModule
postModuleDot DotCompileEnv
cenv DotModuleEnv
DotModuleEnv IsMain
_main TopLevelModuleName
m [DotDef]
_defs = do
  Interface
i <- m Interface
forall (m :: * -> *). ReadTCState m => m Interface
curIF
  let importedModuleNames :: Set TopLevelModuleName
importedModuleNames = [TopLevelModuleName] -> Set TopLevelModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([TopLevelModuleName] -> Set TopLevelModuleName)
-> [TopLevelModuleName] -> Set TopLevelModuleName
forall a b. (a -> b) -> a -> b
$ (TopLevelModuleName, Hash) -> TopLevelModuleName
forall a b. (a, b) -> a
fst ((TopLevelModuleName, Hash) -> TopLevelModuleName)
-> [(TopLevelModuleName, Hash)] -> [TopLevelModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Interface -> [(TopLevelModuleName, Hash)]
iImportedModules Interface
i)
  Bool
include <- case DotCompileEnv -> Maybe (HashSet String)
dotCompileEnvLibraries DotCompileEnv
cenv of
    Maybe (HashSet String)
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just HashSet String
ls -> TCM Bool -> m Bool
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Bool -> m Bool) -> TCM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
      SourceFile
f    <- TopLevelModuleName -> TCM SourceFile
findFile TopLevelModuleName
m
      [AgdaLibFile]
libs <- AbsolutePath -> TopLevelModuleName -> TCM [AgdaLibFile]
getAgdaLibFiles (SourceFile -> AbsolutePath
srcFilePath SourceFile
f) TopLevelModuleName
m

      let incLibs :: [AgdaLibFile]
incLibs = (AgdaLibFile -> Bool) -> [AgdaLibFile] -> [AgdaLibFile]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AgdaLibFile
l -> AgdaLibFile -> String
_libName AgdaLibFile
l String -> HashSet String -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet String
ls) [AgdaLibFile]
libs
          inLib :: Bool
inLib   = Bool -> Bool
not ([AgdaLibFile] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AgdaLibFile]
incLibs)

      String -> VerboseLevel -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCMT IO Doc -> m ()
reportSDoc String
"dot.include" VerboseLevel
10 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
        let name :: TCMT IO Doc
name = TopLevelModuleName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty TopLevelModuleName
m
            list :: [AgdaLibFile] -> TCMT IO Doc
list = VerboseLevel -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCMT IO Doc -> TCMT IO Doc)
-> ([AgdaLibFile] -> TCMT IO Doc) -> [AgdaLibFile] -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc)
-> ([AgdaLibFile] -> [TCMT IO Doc]) -> [AgdaLibFile] -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgdaLibFile -> TCMT IO Doc) -> [AgdaLibFile] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc)
-> (AgdaLibFile -> String) -> AgdaLibFile -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgdaLibFile -> String
_libName)
        if Bool
inLib then
          [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
            ([ TCMT IO Doc
"Including"
             , TCMT IO Doc
name
             ] [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++
             String -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => String -> [m Doc]
pwords String
"because it is in the following libraries:") TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$
          [AgdaLibFile] -> TCMT IO Doc
list [AgdaLibFile]
incLibs
        else
          [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
            (String -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => String -> [m Doc]
pwords String
"Not including" [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++
             [TCMT IO Doc
name TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> TCMT IO Doc
","] [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++
             String -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => String -> [m Doc]
pwords String
"which is in the following libraries:") TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$
          [AgdaLibFile] -> TCMT IO Doc
list [AgdaLibFile]
libs

      Bool -> TCM Bool
forall a. a -> TCM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
inLib

  DotModule -> m DotModule
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DotModule -> m DotModule) -> DotModule -> m DotModule
forall a b. (a -> b) -> a -> b
$ DotModule
    { dotModuleName :: TopLevelModuleName
dotModuleName          = TopLevelModuleName
m
    , dotModuleImportedNames :: Set TopLevelModuleName
dotModuleImportedNames = Set TopLevelModuleName
importedModuleNames
    , dotModuleInclude :: Bool
dotModuleInclude       = Bool
include
    }

postCompileDot
  :: (MonadIO m, ReadTCState m)
  => DotCompileEnv
  -> IsMain
  -> Map TopLevelModuleName DotModule
  -> m ()
postCompileDot :: forall (m :: * -> *).
(MonadIO m, ReadTCState m) =>
DotCompileEnv -> IsMain -> Map TopLevelModuleName DotModule -> m ()
postCompileDot DotCompileEnv
cenv IsMain
_main Map TopLevelModuleName DotModule
modulesByName =
  DotGraph -> String -> m ()
forall (m :: * -> *). MonadIO m => DotGraph -> String -> m ()
renderDotToFile DotGraph
moduleGraph (DotCompileEnv -> String
dotCompileEnvDestination DotCompileEnv
cenv)
  where
  -- Only the keys of this map are used.
  modulesToInclude :: Map TopLevelModuleName DotModule
modulesToInclude =
    (DotModule -> Bool)
-> Map TopLevelModuleName DotModule
-> Map TopLevelModuleName DotModule
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter DotModule -> Bool
dotModuleInclude Map TopLevelModuleName DotModule
modulesByName

  moduleGraph :: Graph (WithUniqueInt L.Text) ()
  moduleGraph :: DotGraph
moduleGraph =
    (WithUniqueInt TopLevelModuleName -> WithUniqueInt Text)
-> Graph (WithUniqueInt TopLevelModuleName) () -> DotGraph
forall n1 n2 e.
(Ord n1, Ord n2) =>
(n1 -> n2) -> Graph n1 e -> Graph n2 e
Graph.renameNodesMonotonic ((TopLevelModuleName -> Text)
-> WithUniqueInt TopLevelModuleName -> WithUniqueInt Text
forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
L.pack (String -> Text)
-> (TopLevelModuleName -> String) -> TopLevelModuleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelModuleName -> String
forall a. Pretty a => a -> String
prettyShow)) (Graph (WithUniqueInt TopLevelModuleName) () -> DotGraph)
-> Graph (WithUniqueInt TopLevelModuleName) () -> DotGraph
forall a b. (a -> b) -> a -> b
$
    Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall n e. Ord n => Graph n e -> Graph n ()
Graph.transitiveReduction (Graph (WithUniqueInt TopLevelModuleName) ()
 -> Graph (WithUniqueInt TopLevelModuleName) ())
-> Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall a b. (a -> b) -> a -> b
$
    (WithUniqueInt TopLevelModuleName -> Bool)
-> Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall n e.
(Ord n, SemiRing e) =>
(n -> Bool) -> Graph n e -> Graph n e
Graph.filterNodesKeepingEdges
      (\WithUniqueInt TopLevelModuleName
n -> WithUniqueInt TopLevelModuleName -> TopLevelModuleName
forall n. WithUniqueInt n -> n
Graph.otherValue WithUniqueInt TopLevelModuleName
n TopLevelModuleName -> Map TopLevelModuleName DotModule -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TopLevelModuleName DotModule
modulesToInclude) (Graph (WithUniqueInt TopLevelModuleName) ()
 -> Graph (WithUniqueInt TopLevelModuleName) ())
-> Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall a b. (a -> b) -> a -> b
$
    -- The following use of transitive reduction should not affect the
    -- semantics. It tends to make the graph smaller, so it might
    -- improve the overall performance of the code, but I did not
    -- verify this.
    Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall n e. Ord n => Graph n e -> Graph n ()
Graph.transitiveReduction (Graph (WithUniqueInt TopLevelModuleName) ()
 -> Graph (WithUniqueInt TopLevelModuleName) ())
-> Graph (WithUniqueInt TopLevelModuleName) ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall a b. (a -> b) -> a -> b
$
    Graph TopLevelModuleName ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall n e. Ord n => Graph n e -> Graph (WithUniqueInt n) e
Graph.addUniqueInts (Graph TopLevelModuleName ()
 -> Graph (WithUniqueInt TopLevelModuleName) ())
-> Graph TopLevelModuleName ()
-> Graph (WithUniqueInt TopLevelModuleName) ()
forall a b. (a -> b) -> a -> b
$
    [Edge TopLevelModuleName ()] -> Graph TopLevelModuleName ()
forall n e. Ord n => [Edge n e] -> Graph n e
Graph.fromEdges ([Edge TopLevelModuleName ()] -> Graph TopLevelModuleName ())
-> [Edge TopLevelModuleName ()] -> Graph TopLevelModuleName ()
forall a b. (a -> b) -> a -> b
$
    ((TopLevelModuleName, DotModule) -> [Edge TopLevelModuleName ()])
-> [(TopLevelModuleName, DotModule)]
-> [Edge TopLevelModuleName ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
       (\ (TopLevelModuleName
name, DotModule
m) ->
          [ Graph.Edge
              { source :: TopLevelModuleName
source = TopLevelModuleName
name
              , target :: TopLevelModuleName
target = TopLevelModuleName
target
              , label :: ()
label  = ()
              }
          | TopLevelModuleName
target <- Set TopLevelModuleName -> [TopLevelModuleName]
forall a. Set a -> [a]
Set.toList (Set TopLevelModuleName -> [TopLevelModuleName])
-> Set TopLevelModuleName -> [TopLevelModuleName]
forall a b. (a -> b) -> a -> b
$ DotModule -> Set TopLevelModuleName
dotModuleImportedNames DotModule
m
          ]) ([(TopLevelModuleName, DotModule)] -> [Edge TopLevelModuleName ()])
-> [(TopLevelModuleName, DotModule)]
-> [Edge TopLevelModuleName ()]
forall a b. (a -> b) -> a -> b
$
    Map TopLevelModuleName DotModule
-> [(TopLevelModuleName, DotModule)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TopLevelModuleName DotModule
modulesByName