calligraphy 0.1.4 → 0.1.5

raw patch · 21 files changed

+561/−262 lines, 21 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +1/−1
• calligraphy.cabal +13/−4
• src/Calligraphy.hs +63/−19
• src/Calligraphy/Compat/Debug.hs +0/−2
• src/Calligraphy/Compat/GHC.hs +6/−5
• src/Calligraphy/Compat/Lib.hs +2/−15
• src/Calligraphy/Phases/DependencyFilter.hs +14/−12
• src/Calligraphy/Phases/EdgeCleanup.hs +4/−2
• src/Calligraphy/Phases/NodeFilter.hs +17/−9
• src/Calligraphy/Phases/Parse.hs +17/−13
• src/Calligraphy/Phases/Render.hs +0/−149
• src/Calligraphy/Phases/Render/Common.hs +152/−0
• src/Calligraphy/Phases/Render/GraphViz.hs +111/−0
• src/Calligraphy/Phases/Render/Mermaid.hs +73/−0
• src/Calligraphy/Phases/Search.hs +0/−1
• src/Calligraphy/Util/LexTree.hs +3/−2
• src/Calligraphy/Util/Printer.hs +28/−24
• src/Calligraphy/Util/Types.hs +5/−2
• src/Prelude.hs +41/−0
• test/Test/LexTree.hs +7/−2

@@ -1,5 +1,9 @@ # Changelog +## 0.1.5+### [Added]+- [#19] [#20] GHC 9.6 support+ ## 0.1.4 ### [Added] - [#16] [#17] GHC 9.4 support

@@ -7,7 +7,7 @@ `calligraphy` is a Haskell call graph/source code visualizer.  It works directly on GHC-generated HIE files, giving us features that would otherwise be tricky, like type information and support for generated files.-`calligraphy` has been tested with all versions of GHC that can produce HIE files (i.e. GHC 8.8, 8.10, 9.0, and 9.2.)+`calligraphy` has been tested with all versions of GHC that produce HIE files (i.e. GHC 8.8 through 9.6.)  See [the accompanying blog post](https://jonascarpay.com/posts/2022-04-26-calligraphy-tutorial.html) for more examples, and an extended tutorial. 

@@ -1,13 +1,15 @@ cabal-version:   2.4 name:            calligraphy-version:         0.1.4+version:         0.1.5 license:         BSD-3-Clause build-type:      Simple license-file:    LICENSE author:          Jonas Carpay maintainer:      Jonas Carpay <jonascarpay@gmail.com> copyright:       2022 Jonas Carpay-tested-with:     GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4+tested-with:+  GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.2+ extra-doc-files:   CHANGELOG.md   README.md@@ -16,7 +18,7 @@ description:   Calligraphy is a Haskell call graph/source code visualizer.   It works directly on GHC-generated HIE files, giving us features that would otherwise be tricky, like type information and support for generated files.-  Calligraphy has been tested with all versions of GHC that can produce HIE files (i.e. GHC 8.8 through 9.4.)+  Calligraphy has been tested with all versions of GHC that produce HIE files (i.e. GHC 8.8 through 9.6.)   See the project's github page for more information.  homepage:        https://github.com/jonascarpay/calligraphy#readme@@ -34,6 +36,10 @@     -Wincomplete-record-updates -Wredundant-constraints     -fhide-source-paths -Wpartial-fields +  mixins:+    base (Prelude as BasePrelude),+    base hiding (Prelude)+ library   import:          common-options   hs-source-dirs:  src@@ -48,13 +54,16 @@     Calligraphy.Phases.EdgeCleanup     Calligraphy.Phases.NodeFilter     Calligraphy.Phases.Parse-    Calligraphy.Phases.Render+    Calligraphy.Phases.Render.Common+    Calligraphy.Phases.Render.GraphViz+    Calligraphy.Phases.Render.Mermaid     Calligraphy.Phases.Search     Calligraphy.Util.Lens     Calligraphy.Util.LexTree     Calligraphy.Util.Optparse     Calligraphy.Util.Printer     Calligraphy.Util.Types+    Prelude    build-depends:     , array

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -9,11 +10,13 @@ import Calligraphy.Phases.EdgeCleanup import Calligraphy.Phases.NodeFilter import Calligraphy.Phases.Parse-import Calligraphy.Phases.Render+import Calligraphy.Phases.Render.Common+import Calligraphy.Phases.Render.GraphViz+import Calligraphy.Phases.Render.Mermaid import Calligraphy.Phases.Search import Calligraphy.Util.Printer import Calligraphy.Util.Types (ppCallGraph)-import Control.Monad.RWS+import Data.IORef import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as Text@@ -55,10 +58,15 @@   let cgCleaned = cleanupEdges edgeFilterConfig cgDependencyFiltered   debug dumpFinal $ ppCallGraph cgCleaned -  let renderConfig' = renderConfig {clusterModules = clusterModules renderConfig && not (collapseModules nodeFilterConfig)}-      txt = runPrinter $ render renderConfig' cgCleaned+  let renderConfig'+        | collapseModules nodeFilterConfig = renderConfig {clusterModules = ClusterNever}+        | otherwise = renderConfig+  renderable <- either (printDie . ppRenderError) pure (renderGraph renderConfig' cgCleaned) -  output outputConfig txt+  output+    outputConfig+    (runPrinter $ renderGraphViz graphVizConfig renderable)+    (runPrinter $ renderMermaid renderable)  data AppConfig = AppConfig   { searchConfig :: SearchConfig,@@ -66,6 +74,7 @@     dependencyFilterConfig :: DependencyFilterConfig,     edgeFilterConfig :: EdgeCleanupConfig,     renderConfig :: RenderConfig,+    graphVizConfig :: GraphVizConfig,     outputConfig :: OutputConfig,     debugConfig :: DebugConfig   }@@ -78,42 +87,69 @@  pConfig :: Parser AppConfig pConfig =-  AppConfig <$> pSearchConfig+  AppConfig+    <$> pSearchConfig     <*> pNodeFilterConfig     <*> pDependencyFilterConfig     <*> pEdgeCleanupConfig     <*> pRenderConfig+    <*> pGraphVizConfig     <*> pOutputConfig     <*> pDebugConfig -output :: OutputConfig -> Text -> IO ()-output cfg@OutputConfig {..} txt = do+output :: OutputConfig -> Text -> Text -> IO ()+output cfg@OutputConfig {..} dotTxt mermaidTxt = do   unless (hasOutput cfg) $ Text.hPutStrLn stderr "Warning: no output options specified, run with --help to see options"-  forM_ outputDotPath $ \fp -> Text.writeFile fp txt+  getSvg <- once $ runDot ["-Tsvg"]+  forM_ outputDotPath $ \fp -> Text.writeFile fp dotTxt   forM_ outputPngPath $ \fp -> runDot ["-Tpng", "-o", fp]-  forM_ outputSvgPath $ \fp -> runDot ["-Tsvg", "-o", fp]-  when outputStdout $ Text.putStrLn txt+  forM_ outputSvgPath $ \fp -> getSvg >>= writeFile fp+  forM_ outputMermaidPath $ \fp -> Text.writeFile fp mermaidTxt+  case outputStdout of+    StdoutDot -> Text.putStrLn dotTxt+    StdoutMermaid -> Text.putStrLn mermaidTxt+    StdoutSVG -> getSvg >>= putStrLn+    StdoutNone -> pure ()   where-    hasOutput (OutputConfig Nothing Nothing Nothing _ False) = False+    hasOutput (OutputConfig Nothing Nothing Nothing Nothing _ StdoutNone) = False     hasOutput _ = True +    once :: IO a -> IO (IO a)+    once act = do+      ref <- newIORef Nothing+      pure $+        readIORef ref >>= \case+          Just a -> pure a+          Nothing -> do+            a <- act+            writeIORef ref (Just a)+            pure a++    runDot :: [String] -> IO String     runDot flags = do       mexe <- findExecutable outputEngine       case mexe of         Nothing -> die $ "Unable to find '" <> outputEngine <> "' executable! Make sure it is installed, or use another output method/engine."         Just exe -> do-          (code, out, err) <- readProcessWithExitCode exe flags (T.unpack txt)-          unless (code == ExitSuccess) $ do-            putStrLn $ outputEngine <> " crashed:"-            putStrLn out-            putStrLn err+          (code, out, err) <- readProcessWithExitCode exe flags (T.unpack dotTxt)+          case code of+            ExitSuccess -> pure out+            _ -> printDie $ do+              strLn $ outputEngine <> " crashed with " <> show code+              strLn "Stdout:"+              indent $ strLn out+              strLn "Stderr:"+              indent $ strLn err +data StdoutFormat = StdoutNone | StdoutDot | StdoutMermaid | StdoutSVG+ data OutputConfig = OutputConfig   { outputDotPath :: Maybe FilePath,     outputPngPath :: Maybe FilePath,     outputSvgPath :: Maybe FilePath,+    outputMermaidPath :: Maybe FilePath,     outputEngine :: String,-    outputStdout :: Bool+    outputStdout :: StdoutFormat   }  pOutputConfig :: Parser OutputConfig@@ -122,8 +158,16 @@     <$> optional (strOption (long "output-dot" <> short 'd' <> metavar "FILE" <> help ".dot output path"))     <*> optional (strOption (long "output-png" <> short 'p' <> metavar "FILE" <> help ".png output path (requires `dot` or other engine in PATH)"))     <*> optional (strOption (long "output-svg" <> short 's' <> metavar "FILE" <> help ".svg output path (requires `dot` or other engine in PATH)"))+    <*> optional (strOption (long "output-mermaid" <> short 'm' <> metavar "FILE" <> help "Mermaid output path"))     <*> strOption (long "render-engine" <> metavar "CMD" <> help "Render engine to use with --output-png and --output-svg" <> value "dot" <> showDefault)-    <*> switch (long "output-stdout" <> help "Output to stdout")+    <*> pStdoutFormat++pStdoutFormat :: Parser StdoutFormat+pStdoutFormat =+  flag' StdoutDot (long "stdout-dot" <> help "Output graphviz dot to stdout")+    <|> flag' StdoutMermaid (long "stdout-mermaid" <> help "Output Mermaid to stdout")+    <|> flag' StdoutSVG (long "stdout-svg" <> help "Output SVG to stdout")+    <|> pure StdoutNone  data DebugConfig = DebugConfig   { dumpHieFile :: Bool,

@@ -9,7 +9,6 @@ where  import Calligraphy.Util.Printer-import Control.Monad import qualified Data.Map as Map  #if MIN_VERSION_ghc(9,2,0)@@ -20,7 +19,6 @@ import qualified GHC.Types.Unique as GHC import qualified GHC.Unit as GHC import qualified GHC.Utils.Outputable as GHC-import GHC.Iface.Ext.Types #elif MIN_VERSION_ghc(9,0,0) import qualified GHC.Data.FastString as GHC import qualified GHC.Iface.Ext.Types as GHC

@@ -44,17 +44,18 @@   ) where +#if MIN_VERSION_ghc(9,6,0)+import Language.Haskell.Syntax.Module.Name (moduleNameString, ModuleName)+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Unit.Module.Name (moduleNameString, ModuleName)+#endif+ #if MIN_VERSION_ghc(9,0,0)-import GHC.Iface.Ext.Binary-import GHC.Iface.Ext.Types import GHC.Iface.Type import GHC.Types.Avail import GHC.Types.Name-import GHC.Types.Name.Cache-import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply-import GHC.Unit.Module.Name import GHC.Unit.Types #else import Avail

@@ -22,31 +22,18 @@ import Calligraphy.Util.Lens import Data.IORef import qualified Data.Set as Set-import Control.Monad--#if MIN_VERSION_ghc(9,0,0)-import GHC.Iface.Ext.Binary-import GHC.Iface.Ext.Types-import GHC.Types.Name.Cache-import GHC.Types.SrcLoc-import GHC.Utils.Outputable (ppr, showSDocUnsafe) import qualified Data.Map as Map-#else-import HieBin-import HieTypes-import NameCache-import SrcLoc-#endif -getHieFiles :: [FilePath] -> IO [HieFile] #if MIN_VERSION_ghc(9,4,0) +getHieFiles :: [FilePath] -> IO [HieFile] getHieFiles filePaths = do   ref <- newIORef =<< GHC.initNameCache 'z' []   forM filePaths (readHieFileWithWarning ref)  #else +getHieFiles :: [FilePath] -> IO [HieFile] getHieFiles filePaths = do     uniqSupply <- GHC.mkSplitUniqSupply 'z'     ref <- newIORef (GHC.initNameCache uniqSupply [])

@@ -11,27 +11,29 @@   ) where -import Calligraphy.Util.Optparse (boolFlags)-import Calligraphy.Util.Printer-import Calligraphy.Util.Types+import Prelude hiding (Decl, DeclType, Node, filter)+ import Control.Monad.State.Strict import Data.Bifunctor (bimap) import Data.EnumMap (EnumMap) import qualified Data.EnumMap as EnumMap import Data.EnumSet (EnumSet) import qualified Data.EnumSet as EnumSet-import Data.Foldable (toList)+import qualified Data.Foldable as Foldable import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set-import Data.Tree+import Data.Tree (Tree)+import qualified Data.Tree as Tree import Data.Tuple (swap) import Options.Applicative-import Prelude hiding (filter) +import Calligraphy.Util.Optparse (boolFlags)+import Calligraphy.Util.Printer+import Calligraphy.Util.Types+ data DependencyFilterConfig = DependencyFilterConfig   { _depRoot :: Maybe (NonEmpty String),     _revDepRoot :: Maybe (NonEmpty String),@@ -77,9 +79,9 @@   where     modules' = over (traverse . modForest) (>>= go) modules     go :: Tree Decl -> [Tree Decl]-    go (Node decl children) = do+    go (Tree.Node decl children) = do       let children' = children >>= go-       in if p decl then pure (Node decl children') else children'+       in if p decl then pure (Tree.Node decl children') else children'  -- | Remove all calls and typings (i.e. edges) where one end is not present in the graph. -- This is intended to be used after an operation that may have removed nodes from the graph.@@ -107,7 +109,7 @@     mkDepFilter :: NonEmpty String -> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)     mkDepFilter rootNames edges = do       rootKeys <- forM rootNames $ \name -> maybe (Left $ UnknownRootName name) (pure . EnumSet.toList) (Map.lookup name names)-      let ins = transitives maxDepth (mconcat $ toList rootKeys) edges+      let ins = transitives maxDepth (mconcat $ Foldable.toList rootKeys) edges       pure $ \decl -> EnumSet.member (declKey decl) ins      edges =@@ -122,8 +124,8 @@     (parentEdges, childEdges) = execState (forT_ (traverse . modForest . traverse) modules go) mempty       where         go :: Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ()-        go (Node parent children) =-          forM_ children $ \childNode@(Node child _) -> do+        go (Tree.Node parent children) =+          forM_ children $ \childNode@(Tree.Node child _) -> do             let kParent = declKey parent                 kChild = declKey child             modify $ bimap (Set.insert (kParent, kChild)) (Set.insert (kChild, kParent))

@@ -3,12 +3,14 @@ -- | This modules collects some opinionated common-sense heuristics for removing edges that are probably redundant. module Calligraphy.Phases.EdgeCleanup (EdgeCleanupConfig, cleanupEdges, pEdgeCleanupConfig) where -import Calligraphy.Util.Types+import Prelude hiding (Node, Decl) import Control.Monad.State.Strict import Data.Set (Set)-import qualified Data.Set as Set import Data.Tree import Options.Applicative+import qualified Data.Set as Set++import Calligraphy.Util.Types (CallGraph(CallGraph), Decl(..), Key, DeclType(..), forT_, modForest)  data EdgeCleanupConfig = EdgeCleanupConfig   { cleanDoubles :: Bool,

@@ -12,16 +12,24 @@ -- The thing that makes it hacky is that it then uses a value node to represent a module. -- This is not actually a huge deal, because no other module actually cares about the node type, but it's something to watch out for. -- There's more design discussion on https://github.com/jonascarpay/calligraphy/pull/5-module Calligraphy.Phases.NodeFilter (filterNodes, NodeFilterConfig (..), pNodeFilterConfig) where+module Calligraphy.Phases.NodeFilter+  ( filterNodes+  , NodeFilterConfig (..)+  , pNodeFilterConfig+  ) where -import Calligraphy.Util.Types+import Prelude hiding (Decl)+ import Control.Monad.State import Data.EnumMap (EnumMap)-import qualified Data.EnumMap as EnumMap import Data.Maybe (catMaybes)-import Data.Tree+import Data.Tree (Tree)+import qualified Data.Tree as Tree import Options.Applicative+import qualified Data.EnumMap as EnumMap +import Calligraphy.Util.Types+ data Mode = Show | Collapse | Hide   deriving (Eq, Show) @@ -67,10 +75,10 @@   where     collapseModule :: Module -> State (EnumMap Key Key) Module     collapseModule (Module modname path []) = pure $ Module modname path []-    collapseModule (Module modname path forest@(Node rep _ : _)) = do+    collapseModule (Module modname path forest@(Tree.Node rep _ : _)) = do       let repKey = declKey rep       forT_ forestT forest $ \decl -> assoc (declKey decl) repKey-      pure $ Module modname path [Node (Decl modname repKey mempty True ValueDecl (Loc 1 1)) []]+      pure $ Module modname path [Tree.Node (Decl modname repKey mempty True ValueDecl (Loc 1 1)) []]      shouldCollapse :: Decl -> Bool     shouldCollapse decl = case declType decl of@@ -90,7 +98,7 @@         typ RecDecl = hideRecords      go :: Maybe Decl -> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))-    go mparent node@(Node decl children)+    go mparent node@(Tree.Node decl children)       | shouldHide decl = do           forM_ mparent $ \parent ->             forM_ node $ \child -> assoc (declKey child) (declKey parent)@@ -98,11 +106,11 @@       | shouldCollapse decl = do           forM_ node $ \child ->             assoc (declKey child) (declKey decl)-          pure $ Just $ Node decl []+          pure $ Just $ Tree.Node decl []       | otherwise = do           assoc (declKey decl) (declKey decl)           children' <- catMaybes <$> mapM (go (Just decl)) children-          pure $ Just $ Node decl children'+          pure $ Just $ Tree.Node decl children'      assoc :: Key -> Key -> State (EnumMap Key Key) ()     assoc key rep = modify (EnumMap.insert key rep)

@@ -12,13 +12,8 @@   ) where -import qualified Calligraphy.Compat.GHC as GHC-import Calligraphy.Compat.Lib (isDerivingNode, isInlineNode, isInstanceNode, isMinimalNode, isTypeSignatureNode, mergeSpans, sourceInfo)-import qualified Calligraphy.Compat.Lib as GHC-import Calligraphy.Util.LexTree (LexTree, TreeError (..), foldLexTree)-import qualified Calligraphy.Util.LexTree as LT-import Calligraphy.Util.Printer-import Calligraphy.Util.Types+import Prelude hiding (Decl, DeclType)+ import Control.Monad.Except import Control.Monad.State import Data.Array (Array)@@ -35,8 +30,17 @@ import Data.Semigroup import Data.Set (Set) import qualified Data.Set as Set-import Data.Tree (Forest, Tree (..))+import Data.Tree (Forest)+import qualified Data.Tree as Tree +import qualified Calligraphy.Compat.GHC as GHC+import Calligraphy.Compat.Lib (isDerivingNode, isInlineNode, isInstanceNode, isMinimalNode, isTypeSignatureNode, mergeSpans, sourceInfo)+import qualified Calligraphy.Compat.Lib as GHC+import Calligraphy.Util.LexTree (LexTree, TreeError (..), foldLexTree)+import qualified Calligraphy.Util.LexTree as LT+import Calligraphy.Util.Printer+import Calligraphy.Util.Types (GHCKey(..), Loc(..), DeclType(..), Decl(..), Key(..), CallGraph(..), Module(..), rekeyCalls, forestT, over, forT_)+ -- | A declaration extracted from the source code. -- -- A single symbol can apparently declare a name multiple times in the same place, with multiple distinct keys D:@@ -105,7 +109,7 @@ newtype ParsePhaseDebugInfo = ParsePhaseDebugInfo {modulesLexTrees :: [(String, LexTree Loc RawDecl)]}  ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo-ppParsePhaseDebugInfo (ParsePhaseDebugInfo mods) = forM_ mods $ \(modName, ltree) -> do+ppParsePhaseDebugInfo (ParsePhaseDebugInfo mods) = Foldable.forM_ mods $ \(modName, ltree) -> do   strLn modName   indent $ ppLexTree ltree @@ -162,7 +166,7 @@     mkDecl :: EnumSet GHCKey -> RawDecl -> HieParse Decl     mkDecl exportSet (RawDecl str ghcKeys typ start _) = do       key <- fresh-      forM_ (EnumSet.toList ghcKeys) (assoc key)+      Foldable.forM_ (EnumSet.toList ghcKeys) (assoc key)       let exported = any (flip EnumSet.member exportSet) (EnumSet.toList ghcKeys)       pure $ Decl str key ghcKeys exported typ start @@ -175,8 +179,8 @@ dedup :: (Ord k, Semigroup v) => Forest (k, v) -> Forest (k, v) dedup = fromDedup . toDedup   where-    fromDedup = fmap (\(k, (v, d)) -> Node (k, v) (fromDedup d)) . Map.toList . unDedup-    toDedup = Dedup . Map.fromListWith (<>) . fmap (\(Node (k, v) f) -> (k, (v, toDedup f)))+    fromDedup = fmap (\(k, (v, d)) -> Tree.Node (k, v) (fromDedup d)) . Map.toList . unDedup+    toDedup = Dedup . Map.fromListWith (<>) . fmap (\(Tree.Node (k, v) f) -> (k, (v, toDedup f)))  newtype Dedup k v = Dedup {unDedup :: Map k (v, Dedup k v)} @@ -230,7 +234,7 @@     go node@(GHC.Node _ _ children) =       forT_ sourceInfo node $ \nodeInfo ->         unless (ignoreNode nodeInfo) $ do-          forM_ (M.toList $ GHC.nodeIdentifiers nodeInfo) $ \case+          Foldable.forM_ (M.toList $ GHC.nodeIdentifiers nodeInfo) $ \case             (Right name, GHC.IdentifierDetails ty info) | not (isGenerated name) -> do               mapM_ (tellType name) ty               case classifyIdentifier info of

@@ -1,149 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---- | Rendering takes a callgraph, and produces a dot file-module Calligraphy.Phases.Render (render, pRenderConfig, RenderConfig (..)) where--import Calligraphy.Util.Printer-import Calligraphy.Util.Types-import Control.Monad-import qualified Data.EnumSet as EnumSet-import Data.List (intercalate)-import Data.Tree (Tree (..))-import Options.Applicative hiding (style)-import Text.Show (showListWith)--data RenderConfig = RenderConfig-  { showCalls :: Bool,-    showTypes :: Bool,-    showKey :: Bool,-    showGHCKeys :: Bool,-    showModulePath :: Bool,-    showChildArrowhead :: Bool,-    locMode :: LocMode,-    clusterModules :: Bool,-    clusterGroups :: Bool,-    splines :: Bool,-    reverseDependencyRank :: Bool-  }--render :: RenderConfig -> Prints CallGraph-render RenderConfig {..} (CallGraph modules calls types) = do-  brack "digraph calligraphy {" "}" $ do-    unless splines $ textLn "splines=false;"-    textLn "node [style=filled fillcolor=\"#ffffffcf\"];"-    textLn "graph [outputorder=edgesfirst];"-    let nonEmptyModules = filter (not . null . moduleForest) modules-    forM_ (zip nonEmptyModules [0 :: Int ..]) $-      \(Module modName modPath forest, moduleIx) ->-        moduleCluster moduleIx (if showModulePath then modPath else modName) $-          forM_ (zip forest [0 :: Int ..]) $ \(root, forestIx) -> do-            treeCluster moduleIx forestIx $-              renderTreeNode root-    when showCalls $-      forM_ calls $ \(caller, callee) ->-        if reverseDependencyRank-          then edge caller callee []-          else edge callee caller ["dir" .= "back"]-    when showTypes $-      forM_ types $ \(caller, callee) ->-        if reverseDependencyRank-          then edge caller callee ["style" .= "dotted"]-          else edge callee caller ["style" .= "dotted", "dir" .= "back"]-  where-    moduleCluster :: Int -> String -> Printer a -> Printer a-    moduleCluster modIx title inner-      | clusterModules =-          brack ("subgraph cluster_module_" <> show modIx <> " {") "}" $ do-            strLn $ "label=" <> show title <> ";"-            inner-      | otherwise = inner-    treeCluster :: Int -> Int -> Printer a -> Printer a-    treeCluster modIx groupIx inner-      | clusterGroups =-          brack ("subgraph cluster_" <> show modIx <> "_" <> show groupIx <> " {") "}" $ do-            textLn "style=invis;"-            inner-      | otherwise = inner-    nodeLabel :: Decl -> String-    nodeLabel (Decl name key ghcKeys _ _ loc) =-      intercalate "\n"-        . cons name-        . consIf showKey (show (unKey key))-        . consManyIf showGHCKeys (fmap (show . unGHCKey) (EnumSet.toList ghcKeys))-        . ( case locMode of-              Hide -> id-              Line -> cons ('L' : show (locLine loc))-              LineCol -> cons (show loc)-          )-        $ []--    renderTreeNode :: Prints (Tree Decl)-    renderTreeNode (Node decl@(Decl _ key _ exported typ _) children) = do-      strLn $ show (unKey key) <> " " <> style ["label" .= ("\"" <> nodeLabel decl <> "\""), "shape" .= nodeShape typ, "style" .= nodeStyle]-      forM_ children $ \child@(Node childDecl _) -> do-        renderTreeNode child-        edge key (declKey childDecl)-          . cons ("style" .= "dashed")-          . consIf (not showChildArrowhead) ("arrowhead" .= "none")-          $ []-      where-        nodeStyle :: String-        nodeStyle =-          show . intercalate ", "-            . consIf (typ == RecDecl) "rounded"-            . consIf (not exported) "dashed"-            . cons "filled"-            $ []--cons :: a -> [a] -> [a]-cons = (:)--consIf :: Bool -> a -> [a] -> [a]-consIf True = (:)-consIf False = flip const--consManyIf :: Foldable f => Bool -> f a -> [a] -> [a]-consManyIf True fs as = foldr (:) as fs-consManyIf False _ as = as--nodeShape :: DeclType -> String-nodeShape DataDecl = "octagon"-nodeShape ConDecl = "box"-nodeShape RecDecl = "box"-nodeShape ClassDecl = "house"-nodeShape ValueDecl = "ellipse"--edge :: MonadPrint m => Key -> Key -> Style -> m ()-edge (Key from) (Key to) sty = strLn $ show from <> " -> " <> show to <> " " <> style sty--(.=) :: String -> String -> (String, String)-(.=) = (,)--style :: Style -> String-style sty = showListWith (\(key, val) -> showString key . showChar '=' . showString val) sty ";"--type Style = [(String, String)]--data LocMode = Hide | Line | LineCol--pLocMode :: Parser LocMode-pLocMode =-  flag' Line (long "show-line" <> help "Show line numbers")-    <|> flag' LineCol (long "show-line-col" <> help "Show line and column numbers")-    <|> pure Hide--pRenderConfig :: Parser RenderConfig-pRenderConfig =-  RenderConfig-    <$> flag True False (long "hide-calls" <> help "Don't show call arrows")-    <*> flag True False (long "hide-types" <> help "Don't show type arrows")-    <*> flag False True (long "show-key" <> help "Show internal keys with identifiers. Useful for debugging.")-    <*> flag False True (long "show-ghc-key" <> help "Show GHC keys with identifiers. Useful for debugging.")-    <*> flag False True (long "show-module-path" <> help "Show a module's filepath instead of its name")-    <*> flag False True (long "show-child-arrowhead" <> help "Put an arrowhead at the end of a parent-child edge")-    <*> pLocMode-    <*> flag True False (long "no-cluster-modules" <> help "Don't draw modules as a cluster.")-    <*> flag True False (long "no-cluster-trees" <> help "Don't draw definition trees as a cluster.")-    <*> flag True False (long "no-splines" <> help "Render arrows as straight lines instead of splines")-    <*> flag False True (long "reverse-dependency-rank" <> help "Make dependencies have lower rank than the dependee, i.e. show dependencies above their parent.")

@@ -0,0 +1,152 @@+{-# LANGUAGE RecordWildCards #-}++-- | Prepare the call graph for rendering+module Calligraphy.Phases.Render.Common+  ( RenderConfig (..),+    pRenderConfig,+    renderGraph,+    RenderError,+    ppRenderError,+    ID,+    RenderGraph (..),+    RenderModule (..),+    RenderNode (..),+    ClusterModules (..),+    if',+  )+where++import Prelude hiding (Decl, DeclType)+import Calligraphy.Util.Printer (Prints, strLn)+import Calligraphy.Util.Types (CallGraph (..), Decl (..), DeclType, GHCKey (unGHCKey), Key (..), Loc (..), Module (..))+import Control.Applicative ((<|>))+import Data.Bifunctor (bimap)+import qualified Data.EnumSet as EnumSet+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Tree (Tree)+import Options.Applicative (Parser, flag, flag', help, long)++data RenderConfig = RenderConfig+  { showCalls :: Bool,+    showTypes :: Bool,+    showKey :: Bool,+    showGHCKeys :: Bool,+    showModulePath :: Bool,+    locMode :: LocMode,+    clusterModules :: ClusterModules+  }++data ClusterModules+  = ClusterNever+  | ClusterWhenMultiple+  | ClusterAlways++pRenderConfig :: Parser RenderConfig+pRenderConfig =+  RenderConfig+    <$> flag True False (long "hide-calls" <> help "Don't show call arrows")+    <*> flag True False (long "hide-types" <> help "Don't show type arrows")+    <*> flag False True (long "show-key" <> help "Show internal keys with identifiers. Useful for debugging.")+    <*> flag False True (long "show-ghc-key" <> help "Show GHC keys with identifiers. Useful for debugging.")+    <*> flag False True (long "show-module-path" <> help "Show a module's filepath instead of its name")+    <*> pLocMode+    <*> pClusterModules++pClusterModules :: Parser ClusterModules+pClusterModules =+  flag' ClusterNever (long "no-cluster-modules" <> help "Don't draw modules as a cluster.")+    <|> flag' ClusterAlways (long "force-cluster-modules" <> help "Draw modules as a cluster, even if there is only one.")+    <|> pure ClusterWhenMultiple++-- | A directly printable string uniquely identifying a declaration.+type ID = String++-- | A representation of the call graph that's convenient for rendering.+-- Structurally, it's the same as 'CallGraph', in that it's a tree of nodes and a flat list of edges.+-- The differences is that as much of the non-backend-specific preprocessing has already been taken care of.+--   - Nodes and modules have a unique string ID+--   - Nodes and modules contain their desired label+--   - Render roots are guaranteed to be non-empty+--   - Set of calls and types are empty on --hide-{calls, types}+--   - Modules are flattened depending on --no-cluster-modules+data RenderGraph = RenderGraph+  { renderRoots :: Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode)), -- Right if --no-cluster-modules+    callEdges :: Set (ID, ID), -- empty if --hide-calls+    typeEdges :: Set (ID, ID) -- empty if --hide-types+  }++data RenderModule = RenderModule+  { moduleLabel :: String,+    moduleId :: ID,+    moduleDecls :: NonEmpty (Tree RenderNode)+  }++data RenderNode = RenderNode+  { nodeId :: ID,+    nodeType :: DeclType,+    nodeLabelLines :: [String],+    nodeExported :: Bool+  }++data LocMode = Hide | Line | LineCol++data RenderError = EmptyGraph++ppRenderError :: Prints RenderError+ppRenderError EmptyGraph = strLn "Output graph is empty"++renderGraph :: RenderConfig -> CallGraph -> Either RenderError RenderGraph+renderGraph+  RenderConfig {..}+  (CallGraph modules calls types) =+    case nonEmpty (mapMaybe (uncurry mkModule) (zip modules [0 ..])) of+      Nothing -> Left EmptyGraph+      Just neModules ->+        pure $+          RenderGraph+            ( let cluster = case clusterModules of+                    ClusterAlways -> True+                    ClusterWhenMultiple -> length neModules > 1+                    ClusterNever -> False+               in if cluster then Left neModules else Right (neModules >>= moduleDecls)+            )+            (if showCalls then Set.map (bimap keyId keyId) calls else Set.empty)+            (if showTypes then Set.map (bimap keyId keyId) types else Set.empty)+    where+      keyId :: Key -> ID+      keyId (Key k) = "node_" <> show k++      mkModule :: Module -> Int -> Maybe RenderModule+      mkModule (Module name path decls) ix =+        (\ne -> RenderModule label ("module_" <> show ix) (fmap mkNode <$> ne)) <$> nonEmpty decls+        where+          label+            | showModulePath = path+            | otherwise = name++      mkNode :: Decl -> RenderNode+      mkNode (Decl name key ghcKeys x t loc) = RenderNode (keyId key) t (catMaybes lbls) x+        where+          lbls =+            [ pure name,+              if' showKey $ show (unKey key),+              if' showGHCKeys $ "GHC Keys: " <> (unwords . fmap (show . unGHCKey) . EnumSet.toList $ ghcKeys),+              case locMode of+                Hide -> Nothing+                Line -> Just ('L' : show (locLine loc))+                LineCol -> Just (show loc)+            ]++pLocMode :: Parser LocMode+pLocMode =+  flag' Line (long "show-line" <> help "Show line numbers")+    <|> flag' LineCol (long "show-line-col" <> help "Show line and column numbers")+    <|> pure Hide++-- TODO this needs to be moved to an appropriate Util/Lib module+if' :: Bool -> a -> Maybe a+if' True a = Just a+if' False _ = Nothing

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Rendering takes a callgraph, and produces a dot file+module Calligraphy.Phases.Render.GraphViz+  ( GraphVizConfig,+    pGraphVizConfig,+    renderGraphViz,+  )+where++import Prelude hiding (DeclType)++import Calligraphy.Phases.Render.Common+import Calligraphy.Util.Printer+import Calligraphy.Util.Types+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Tree (Tree)+import qualified Data.Tree as Tree+import Options.Applicative hiding (style)+import Text.Show (showListWith)++data GraphVizConfig = GraphVizConfig+  { showChildArrowhead :: Bool,+    clusterGroups :: Bool,+    splines :: Bool,+    reverseDependencyRank :: Bool+  }++pGraphVizConfig :: Parser GraphVizConfig+pGraphVizConfig =+  GraphVizConfig+    <$> flag False True (long "show-child-arrowhead" <> help "Put an arrowhead at the end of a parent-child edge")+    <*> flag True False (long "no-cluster-trees" <> help "Don't draw definition trees as a cluster.")+    <*> flag True False (long "no-splines" <> help "Render arrows as straight lines instead of splines")+    <*> flag False True (long "reverse-dependency-rank" <> help "Make dependencies have lower rank than the dependee, i.e. show dependencies above their parent.")++renderGraphViz :: GraphVizConfig -> Prints RenderGraph+renderGraphViz GraphVizConfig {..} (RenderGraph roots calls types) = do+  brack "digraph calligraphy {" "}" $ do+    unless splines $ textLn "splines=false;"+    textLn "node [style=filled fillcolor=\"#ffffffcf\"];"+    textLn "graph [outputorder=edgesfirst];"+    case roots of+      Left modules -> mapM_ printModule modules+      Right trees -> mapM_ printTree trees+    forM_ calls $ \(caller, callee) ->+      if reverseDependencyRank+        then edge caller callee []+        else edge callee caller ["dir" .= "back"]+    forM_ types $ \(caller, callee) ->+      if reverseDependencyRank+        then edge caller callee ["style" .= "dotted"]+        else edge callee caller ["style" .= "dotted", "dir" .= "back"]+  where+    printTree :: Prints (Tree RenderNode)+    printTree (Tree.Node nodeInfo children) = wrapCluster $ do+      printNode nodeInfo+      forM_ children $ \child@(Tree.Node childInfo _) -> do+        printTree child+        edge (nodeId nodeInfo) (nodeId childInfo) . catMaybes $+          [ pure ("style" .= "dashed"),+            if' (not showChildArrowhead) ("arrowhead" .= "none")+          ]+      where+        wrapCluster inner+          | clusterGroups && not (null children) = brack ("subgraph cluster_" <> nodeId nodeInfo <> " {") "}" $ do+              textLn "style=invis;"+              inner+          | otherwise = inner++    printModule :: Prints RenderModule+    printModule (RenderModule lbl modId trees) =+      brack ("subgraph cluster_module_" <> modId <> " {") "}" $ do+        strLn $ "label=" <> show lbl <> ";"+        forM_ trees printTree++    printNode :: Prints RenderNode+    printNode (RenderNode nId typ lbll exported) =+      strLn $ nId <> " " <> renderAttrs attrs+      where+        attrs =+          [ "label" .= ("\"" <> intercalate "\n" lbll <> "\""),+            "shape" .= nodeShape typ,+            "style" .= nodeStyle+          ]+        nodeStyle =+          show . intercalate ", " . catMaybes $+            [ if' (typ == RecDecl) "rounded",+              if' (not exported) "dashed",+              pure "filled"+            ]++nodeShape :: DeclType -> String+nodeShape DataDecl = "octagon"+nodeShape ConDecl = "box"+nodeShape RecDecl = "box"+nodeShape ClassDecl = "house"+nodeShape ValueDecl = "ellipse"++edge :: ID -> ID -> Attributes -> Printer ()+edge from to attrs = strLn $ show from <> " -> " <> show to <> " " <> renderAttrs attrs++(.=) :: String -> String -> (String, String)+(.=) = (,)++renderAttrs :: Attributes -> String+renderAttrs attrs = showListWith (\(key, val) -> showString key . showChar '=' . showString val) attrs ";"++type Attributes = [(String, String)]

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Calligraphy.Phases.Render.Mermaid+  ( renderMermaid,+  )+where++import Prelude hiding (Node, Decl, DeclType)+import Calligraphy.Phases.Render.Common+import Calligraphy.Util.Printer+import Calligraphy.Util.Types+import Control.Monad.State (State, execState, modify)+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Tree (Tree (..))++renderMermaid :: Prints RenderGraph+renderMermaid (RenderGraph roots calls types) = do+  textLn "flowchart TD"+  indent $ do+    case roots of+      Left modules -> mapM_ printModule modules+      Right trees -> mapM_ printTree trees+    forM_ (removeZeroEdges calls) $ \(caller, callee) ->+      strLn $ caller <> " --> " <> callee+    forM_ (removeZeroEdges types) $ \(caller, callee) ->+      strLn $ caller <> " -.-> " <> callee+    strLn "classDef default fill-opacity:0,stroke:#777;"+  where+    printTree :: Prints (Tree RenderNode)+    printTree (Node (RenderNode nodeid typ lbll export) []) = do+      strLn $ nodeid <> nodeShape typ (intercalate "\\n" lbll)+      unless export . strLn $+        "style " <> nodeid <> " stroke-dasharray: 5 5"+    printTree (Node (RenderNode nodeid _typ lbll export) children) = do+      brack ("subgraph " <> nodeid <> "[" <> intercalate "\\n" lbll <> "]") "end" $ do+        unless export . strLn $+          "style " <> nodeid <> " stroke-dasharray: 5 5"+        forM_ children printTree+    -- strLn $ nodeid <> " ~~~ " <> nodeId childNode++    printModule :: Prints RenderModule+    printModule (RenderModule lbl modId decls) =+      brack ("subgraph " <> modId <> " [" <> lbl <> "]") "end" $+        forM_ decls printTree++    -- Because we render hierarchies using subgraphs, there's an odd edge case+    -- when theres an edge between a parent and child; mermaid renders these as+    -- a zero-length edge, i.e. _just_ an arrowhead. So, we remove them.+    removeZeroEdges :: Set (ID, ID) -> Set (ID, ID)+    removeZeroEdges = execState (mapM_ go declRoots)+      where+        declRoots :: NonEmpty (Tree RenderNode)+        declRoots = case roots of+          Left mods -> mods >>= moduleDecls+          Right a -> a+        go :: Tree RenderNode -> State (Set (ID, ID)) ()+        go (Node (RenderNode parentId _ _ _) children) = do+          forM_ children $ \child@(Node (RenderNode childId _ _ _) _) -> do+            modify $ Set.delete (parentId, childId)+            go child++nodeShape :: DeclType -> String -> String+nodeShape DataDecl = wrapBracket "([" "])"+nodeShape ValueDecl = wrapBracket "[" "]"+nodeShape RecDecl = wrapBracket "(" ")"+nodeShape ConDecl = wrapBracket "(" ")"+nodeShape ClassDecl = wrapBracket "[/" "\\]"++wrapBracket :: String -> String -> String -> String+wrapBracket p q inner = p <> inner <> q

@@ -10,7 +10,6 @@ import qualified Calligraphy.Compat.GHC as GHC import Calligraphy.Compat.Lib import Control.Applicative-import Data.List (isPrefixOf) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList) import Options.Applicative hiding (str) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)

@@ -33,7 +33,8 @@ where  import Control.Applicative-import Data.Tree (Forest, Tree (..))+import Data.Tree (Forest)+import qualified Data.Tree as Tree  data LexTree p a   = Tip@@ -91,7 +92,7 @@ toForest :: LexTree p a -> Forest (p, a, p) toForest lt = foldLexTree id f lt []   where-    f ls l a m r rs = ls . (Node (l, a, r) (m []) :) . rs+    f ls l a m r rs = ls . (Tree.Node (l, a, r) (m []) :) . rs  {-# INLINE height #-} height :: LexTree p a -> Int

@@ -1,17 +1,27 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Calligraphy.Util.Printer where+module Calligraphy.Util.Printer+  ( Printer,+    Prints,+    runPrinter,+    indent,+    brack,+    strLn,+    textLn,+    showLn,+  )+where  import Control.Monad.RWS-import Control.Monad.State-import Data.Foldable import Data.Text (Text) import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as TB -newtype Printer a = Printer {unPrinter :: RWS Int () Builder a}+-- | An monadic interface to a fairly primitive line printer.+-- It maintains an indentation level, and provides efficient concatenation through 'Builder', and that's it.+newtype Printer a = Printer {_unPrinter :: RWS Int () Builder a}   deriving newtype (Functor, Applicative, Monad)   deriving (Semigroup, Monoid) via (Ap Printer a) @@ -20,36 +30,30 @@ runPrinter :: Printer () -> Text runPrinter (Printer p) = TL.toStrict . TB.toLazyText . fst $ execRWS p 0 mempty -class Monad m => MonadPrint m where-  line :: Builder -> m ()-  indent :: m a -> m a--instance MonadPrint Printer where-  {-# INLINE indent #-}-  indent (Printer p) = Printer $ local (+ 4) p--  {-# INLINE line #-}-  line t = Printer $ do-    n <- ask-    modify $-      flip mappend $ fold (replicate n (TB.singleton ' ')) <> t <> TB.singleton '\n'+{-# INLINE indent #-}+indent :: Printer a -> Printer a+indent (Printer p) = Printer $ local (+ 4) p -instance MonadPrint m => MonadPrint (StateT s m) where-  line = lift . line-  indent (StateT m) = StateT $ indent . m+{-# INLINE line #-}+line :: Builder -> Printer ()+line t = Printer $ do+  n <- ask+  modify $+    flip mappend $+      fold (replicate n (TB.singleton ' ')) <> t <> TB.singleton '\n'  {-# INLINE brack #-}-brack :: MonadPrint m => String -> String -> m a -> m a+brack :: String -> String -> Printer a -> Printer a brack pre post inner = strLn pre *> indent inner <* strLn post  {-# INLINE strLn #-}-strLn :: MonadPrint m => String -> m ()+strLn :: String -> Printer () strLn = line . TB.fromString  {-# INLINE textLn #-}-textLn :: MonadPrint m => Text -> m ()+textLn :: Text -> Printer () textLn = line . TB.fromText  {-# INLINE showLn #-}-showLn :: (MonadPrint m, Show a) => a -> m ()+showLn :: (Show a) => a -> Printer () showLn = strLn . show

@@ -24,9 +24,9 @@   ) where +import Prelude hiding (Decl, DeclType, Node) import Calligraphy.Util.Lens import Calligraphy.Util.Printer-import Control.Monad import Data.Bitraversable (bitraverse) import Data.EnumMap (EnumMap) import qualified Data.EnumMap as EnumMap@@ -98,7 +98,10 @@ forestT = traverse . traverse  rekeyCalls :: (Enum a, Ord b) => EnumMap a b -> Set (a, a) -> Set (b, b)-rekeyCalls m = foldr (maybe id Set.insert . bitraverse (flip EnumMap.lookup m) (flip EnumMap.lookup m)) mempty+rekeyCalls m =+  foldr+    (maybe id Set.insert . bitraverse (flip EnumMap.lookup m) (flip EnumMap.lookup m))+    mempty  ppCallGraph :: Prints CallGraph ppCallGraph (CallGraph modules _ _) = forM_ modules $ \(Module modName modPath forest) -> do

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+module Prelude +  ( module P+  , module Control.Monad+  , module Data.Either+  , module Data.Foldable+  , module Data.List+  , module Data.Monoid+#if MIN_VERSION_ghc(9,0,0)+  , module GHC.Iface.Ext.Binary+  , module GHC.Iface.Ext.Types+  , module GHC.Types.Name.Cache+  , module GHC.Types.SrcLoc+  , module GHC.Utils.Outputable +#else+  , module HieBin+  , module HieTypes+  , module NameCache+  , module SrcLoc+#endif+  ) where++import Control.Monad+import Data.Either+import Data.Foldable hiding (toList)+import Data.List (last, (++), replicate, zip, filter, isPrefixOf)+import Data.Monoid (Monoid, mempty, mconcat, mappend, Ap(..))+import qualified BasePrelude as P +import BasePrelude+#if MIN_VERSION_ghc(9,0,0)+import GHC.Iface.Ext.Binary+import GHC.Iface.Ext.Types+import GHC.Types.Name.Cache+import GHC.Types.SrcLoc+import GHC.Utils.Outputable (ppr, showSDocUnsafe)+#else+import HieBin+import HieTypes+import NameCache+import SrcLoc+#endif

@@ -1,17 +1,22 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Test.LexTree where  import Calligraphy.Util.LexTree-import Control.Applicative-import Control.Monad import qualified Data.Foldable as Foldable import Data.Maybe (fromMaybe, isJust) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck++#if MIN_VERSION_base(4,18,0)+import Control.Applicative ()+#else+import Control.Applicative (liftA2)+#endif  instance (Arbitrary a, Arbitrary p, Ord p, Num p) => Arbitrary (LexTree p a) where   arbitrary = sized goSized