calligraphy 0.1.1 → 0.1.2

raw patch · 14 files changed

+325/−254 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• calligraphy.cabal +2/−2
• src/Calligraphy.hs +6/−5
• src/Calligraphy/Compat/Debug.hs +3/−3
• src/Calligraphy/Compat/GHC.hs +2/−0
• src/Calligraphy/Compat/Lib.hs +3/−3
• src/Calligraphy/Phases/Collapse.hs +0/−86
• src/Calligraphy/Phases/DependencyFilter.hs +1/−1
• src/Calligraphy/Phases/NodeFilter.hs +108/−0
• src/Calligraphy/Phases/Parse.hs +170/−148
• src/Calligraphy/Phases/Render.hs +1/−1
• src/Calligraphy/Util/LexTree.hs +7/−0
• src/Calligraphy/Util/Printer.hs +5/−0
• src/Calligraphy/Util/Types.hs +11/−5

@@ -1,5 +1,11 @@ # Changelog +## 0.1.2++### [Added]++- `--collapse-modules` option to collapse entire modules into a single node+ ## 0.1.1  ### [Changed]

@@ -1,6 +1,6 @@ cabal-version:   2.4 name:            calligraphy-version:         0.1.1+version:         0.1.2 license:         BSD-3-Clause build-type:      Simple license-file:    LICENSE@@ -44,9 +44,9 @@     Calligraphy.Compat.Debug     Calligraphy.Compat.GHC     Calligraphy.Compat.Lib-    Calligraphy.Phases.Collapse     Calligraphy.Phases.DependencyFilter     Calligraphy.Phases.EdgeCleanup+    Calligraphy.Phases.NodeFilter     Calligraphy.Phases.Parse     Calligraphy.Phases.Render     Calligraphy.Phases.Search

@@ -5,9 +5,9 @@  import Calligraphy.Compat.Debug (ppHieFile) import qualified Calligraphy.Compat.GHC as GHC-import Calligraphy.Phases.Collapse import Calligraphy.Phases.DependencyFilter import Calligraphy.Phases.EdgeCleanup+import Calligraphy.Phases.NodeFilter import Calligraphy.Phases.Parse import Calligraphy.Phases.Render import Calligraphy.Phases.Search@@ -50,18 +50,19 @@    (parsePhaseDebug, cgParsed) <- either (printDie . ppParseError) pure (parseHieFiles hieFiles)   debug dumpLexicalTree $ ppParsePhaseDebugInfo parsePhaseDebug-  let cgCollapsed = collapse collapseConfig cgParsed+  let cgCollapsed = filterNodes nodeFilterConfig cgParsed   cgDependencyFiltered <- either (printDie . ppFilterError) pure $ dependencyFilter dependencyFilterConfig cgCollapsed   let cgCleaned = cleanupEdges edgeFilterConfig cgDependencyFiltered   debug dumpFinal $ ppCallGraph cgCleaned -  let txt = runPrinter $ render renderConfig cgCleaned+  let renderConfig' = renderConfig {clusterModules = clusterModules renderConfig && not (collapseModules nodeFilterConfig)}+      txt = runPrinter $ render renderConfig' cgCleaned    output outputConfig txt  data AppConfig = AppConfig   { searchConfig :: SearchConfig,-    collapseConfig :: CollapseConfig,+    nodeFilterConfig :: NodeFilterConfig,     dependencyFilterConfig :: DependencyFilterConfig,     edgeFilterConfig :: EdgeCleanupConfig,     renderConfig :: RenderConfig,@@ -78,7 +79,7 @@ pConfig :: Parser AppConfig pConfig =   AppConfig <$> pSearchConfig-    <*> pCollapseConfig+    <*> pNodeFilterConfig     <*> pDependencyFilterConfig     <*> pEdgeCleanupConfig     <*> pRenderConfig

@@ -77,15 +77,15 @@     forM_ (Map.toList ids) $ \(idn, GHC.IdentifierDetails _ idnDetails) -> do       ppIdentifier idn       indent $ forM_ idnDetails $ strLn . GHC.showSDocOneLine (GHC.initSDocContext GHC.unsafeGlobalDynFlags GHC.defaultUserStyle) . GHC.ppr-    forM_ anns $ strLn . show+    forM_ anns $ showLn   indent $ mapM_ ppAst children #else ppAst (GHC.Node (GHC.NodeInfo anns _ ids) spn children) = do   strLn (showSpan spn)   forM_ (Map.toList ids) $ \(idn, GHC.IdentifierDetails _ idnDetails) -> do     ppIdentifier idn-    indent $ forM_ idnDetails $ strLn . show-  forM_ anns $ strLn . show+    indent $ forM_ idnDetails showLn+  mapM_ showLn anns   indent $ mapM_ ppAst children #endif 

@@ -39,6 +39,8 @@     srcSpanStartLine,     srcSpanEndCol,     srcSpanEndLine,+    srcLocCol,+    srcLocLine,   ) where 

@@ -12,7 +12,7 @@     isMinimalNode,     isDerivingNode,     showAnns,-    spanSpans,+    mergeSpans,     isPointSpan,   ) where@@ -99,8 +99,8 @@  #endif -spanSpans :: Span -> Span -> Span-spanSpans sp1 sp2 =+mergeSpans :: Span -> Span -> Span+mergeSpans sp1 sp2 =   mkRealSrcSpan     ( min         (realSrcSpanStart sp1)

@@ -1,86 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | This modules manages the two ways we remove nodes from a graph; collapsing and hiding.------ Collapsing means folding a node's descendants into itself, merging all incoming and outcoming edges.------ Hiding means removing a node (and its descendants), moving the edges into the node's parent, if a parent exist.------ Since these are essentially the same thing from different perspectives, they are handled by the same module.-module Calligraphy.Phases.Collapse (collapse, CollapseConfig, pCollapseConfig) where--import Calligraphy.Util.Types-import Control.Monad.State-import Data.EnumMap (EnumMap)-import qualified Data.EnumMap as EnumMap-import Data.Maybe (catMaybes)-import Data.Tree-import Options.Applicative--data Mode = Show | Collapse | Hide-  deriving (Eq, Show)--data CollapseConfig = CollapseConfig-  { hideLocals :: Bool,-    collapseClasses :: Mode,-    collapseData :: Mode,-    collapseValues :: Mode,-    collapseConstructors :: Mode,-    hideRecords :: Bool-  }--pCollapseConfig :: Parser CollapseConfig-pCollapseConfig =-  CollapseConfig-    <$> switch (long "exports-only" <> long "hide-local-bindings" <> help "Remove all non-exported bindings, merging all edges into its parent, if one exist.")-    <*> pMode "classes" "Remove all class nodes's children, merging the children's edges into itself." "Remove all class nodes and their children."-    <*> pMode "data" "Remove all data nodes's children, merging the children's edges into itself." "Remove all data nodes and their children, merging all edges into the data node's parent, if one exists."-    <*> pMode "values" "Remove all value nodes's children, merging the children's edges into itself." "Remove all value nodes and their children, merging all edges into the value node's parent, if one exists."-    <*> pMode "constructors" "Remove all constructor nodes's children, merging the children's edges into itself." "Remove all constructor nodes and their children, merging all edges into the constructor node's parent, if one exists."-    <*> flag False True (long "hide-records" <> help "Remove all record nodes.")-  where-    pMode :: String -> String -> String -> Parser Mode-    pMode flagName collapseHelp hideHelp =-      flag' Collapse (long ("collapse-" <> flagName) <> help collapseHelp)-        <|> flag' Hide (long ("hide-" <> flagName) <> help hideHelp)-        <|> pure Show--collapse :: CollapseConfig -> CallGraph -> CallGraph-collapse CollapseConfig {..} (CallGraph modules calls types) =-  let (modules', reps) = flip runState mempty $ (traverse . modForest) (fmap catMaybes . traverse (go Nothing)) modules-   in CallGraph modules' (rekeyCalls reps calls) (rekeyCalls reps types)-  where-    shouldCollapse :: Decl -> Bool-    shouldCollapse decl = case declType decl of-      ValueDecl -> collapseValues == Collapse-      ClassDecl -> collapseClasses == Collapse-      ConDecl -> collapseConstructors == Collapse-      DataDecl -> collapseData == Collapse-      _ -> False--    shouldHide :: Decl -> Bool-    shouldHide decl = typ (declType decl) || (hideLocals && not (declExported decl))-      where-        typ ClassDecl = collapseClasses == Hide-        typ DataDecl = collapseData == Hide-        typ ValueDecl = collapseValues == Hide-        typ ConDecl = collapseConstructors == Hide-        typ RecDecl = hideRecords--    go :: Maybe Decl -> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))-    go mparent node@(Node decl children)-      | shouldHide decl = do-          forM_ mparent $ \parent ->-            forM_ node $ \child -> assoc (declKey child) (declKey parent)-          pure Nothing-      | shouldCollapse decl = do-          forM_ node $ \child ->-            assoc (declKey child) (declKey decl)-          pure $ Just $ Node decl []-      | otherwise = do-          assoc (declKey decl) (declKey decl)-          children' <- catMaybes <$> mapM (go (Just decl)) children-          pure $ Just $ Node decl children'--    assoc :: Key -> Key -> State (EnumMap Key Key) ()-    assoc key rep = modify (EnumMap.insert key rep)

@@ -134,7 +134,7 @@ resolveNames :: Module -> Map String (EnumSet Key) resolveNames (Module modName _ forest) =   flip execState mempty $-    flip (traverse . traverse) forest $+    flip forestT forest $       \(Decl name key _ _ _ _) ->         modify $           Map.insertWith (<>) (modName <> "." <> name) (EnumSet.singleton key)

@@ -0,0 +1,108 @@+{-# LANGUAGE RecordWildCards #-}++-- | This modules manages the two ways we remove nodes from a graph; collapsing and hiding.+--+-- Collapsing means absorbing a node's descendants into itself, including all edges.+--+-- Hiding means removing a node (and its descendants), moving the edges to the node's parent, if a parent exist.+--+-- There's also the special option --collapse-modules.+-- It's undeniably a little hacky, but for now this is the best home for that functionality.+-- Functionality-wise, it's still essentially just collapsing nodes into one another.+-- 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++import Calligraphy.Util.Types+import Control.Monad.State+import Data.EnumMap (EnumMap)+import qualified Data.EnumMap as EnumMap+import Data.Maybe (catMaybes)+import Data.Tree+import Options.Applicative++data Mode = Show | Collapse | Hide+  deriving (Eq, Show)++data NodeFilterConfig = NodeFilterConfig+  { hideLocals :: Bool,+    collapseModules :: Bool,+    collapseClasses :: Mode,+    collapseData :: Mode,+    collapseValues :: Mode,+    collapseConstructors :: Mode,+    hideRecords :: Bool+  }++pNodeFilterConfig :: Parser NodeFilterConfig+pNodeFilterConfig =+  NodeFilterConfig+    <$> switch (long "exports-only" <> long "hide-local-bindings" <> help "Remove all non-exported bindings, merging all edges into its parent, if one exist.")+    <*> switch (long "collapse-modules" <> help "Collapse all nodes into a single node per module.")+    <*> pMode "classes" "class"+    <*> pMode "data" "data"+    <*> pMode "values" "value"+    <*> pMode "constructors" "constructor"+    <*> flag False True (long "hide-records" <> help "Remove all record nodes.")+  where+    pMode :: String -> String -> Parser Mode+    pMode flagName helpName =+      flag' Collapse (long ("collapse-" <> flagName) <> help collapseHelp)+        <|> flag' Hide (long ("hide-" <> flagName) <> help hideHelp)+        <|> pure Show+      where+        collapseHelp = "Remove all " <> helpName <> " nodes's children, merging the children's edges into itself."+        hideHelp = "Remove all " <> helpName <> " nodes and their children."++filterNodes :: NodeFilterConfig -> CallGraph -> CallGraph+filterNodes NodeFilterConfig {..} (CallGraph modules calls types) =+  let (modules', reps) =+        flip runState mempty $+          forM modules $+            if collapseModules+              then collapseModule+              else modForest (fmap catMaybes . traverse (go Nothing))+   in CallGraph modules' (rekeyCalls reps calls) (rekeyCalls reps types)+  where+    collapseModule :: Module -> State (EnumMap Key Key) Module+    collapseModule (Module modname path []) = pure $ Module modname path []+    collapseModule (Module modname path forest@(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)) []]++    shouldCollapse :: Decl -> Bool+    shouldCollapse decl = case declType decl of+      ValueDecl -> collapseValues == Collapse+      ClassDecl -> collapseClasses == Collapse+      ConDecl -> collapseConstructors == Collapse+      DataDecl -> collapseData == Collapse+      _ -> False++    shouldHide :: Decl -> Bool+    shouldHide decl = typ (declType decl) || (hideLocals && not (declExported decl))+      where+        typ ClassDecl = collapseClasses == Hide+        typ DataDecl = collapseData == Hide+        typ ValueDecl = collapseValues == Hide+        typ ConDecl = collapseConstructors == Hide+        typ RecDecl = hideRecords++    go :: Maybe Decl -> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))+    go mparent node@(Node decl children)+      | shouldHide decl = do+          forM_ mparent $ \parent ->+            forM_ node $ \child -> assoc (declKey child) (declKey parent)+          pure Nothing+      | shouldCollapse decl = do+          forM_ node $ \child ->+            assoc (declKey child) (declKey decl)+          pure $ Just $ Node decl []+      | otherwise = do+          assoc (declKey decl) (declKey decl)+          children' <- catMaybes <$> mapM (go (Just decl)) children+          pure $ Just $ Node decl children'++    assoc :: Key -> Key -> State (EnumMap Key Key) ()+    assoc key rep = modify (EnumMap.insert key rep)

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,7 +13,7 @@ where  import qualified Calligraphy.Compat.GHC as GHC-import Calligraphy.Compat.Lib (isDerivingNode, isInlineNode, isInstanceNode, isMinimalNode, isTypeSignatureNode, sourceInfo, spanSpans)+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@@ -22,7 +23,6 @@ import Control.Monad.State import Data.Array (Array) import qualified Data.Array as Array-import Data.Bifunctor (first) import Data.EnumMap (EnumMap) import qualified Data.EnumMap as EnumMap import Data.EnumSet (EnumSet)@@ -32,87 +32,77 @@ import Data.Map (Map) import qualified Data.Map as M import qualified Data.Map as Map+import Data.Semigroup import Data.Set (Set) import qualified Data.Set as Set-import Data.Tree (Forest)-import qualified Data.Tree as Tree---- TODO This can be faster by storing intermediate restuls, but that has proven tricky to get right.-resolveTypes :: Array GHC.TypeIndex GHC.HieTypeFlat -> EnumMap GHC.TypeIndex (EnumSet GHCKey)-resolveTypes typeArray = EnumMap.fromList [(ix, evalState (go ix) mempty) | ix <- Array.indices typeArray]-  where-    keys :: GHC.HieType a -> EnumSet GHCKey-    keys (GHC.HTyConApp (GHC.IfaceTyCon name _) _) = EnumSet.singleton (ghcNameKey name)-    keys (GHC.HForAllTy ((name, _), _) _) = EnumSet.singleton (ghcNameKey name)-    -- These are variables, which we ignore, but it can't hurt-    keys (GHC.HTyVarTy name) = EnumSet.singleton (ghcNameKey name)-    keys _ = mempty-    go :: GHC.TypeIndex -> State (EnumSet GHC.TypeIndex) (EnumSet GHCKey)-    go current =-      gets (EnumSet.member current) >>= \case-        True -> pure mempty-        False -> do-          modify (EnumSet.insert current)-          let ty = typeArray Array.! current-          mappend (keys ty) . mconcat <$> mapM go (Foldable.toList ty)--type GHCDecl = (DeclType, GHC.Span, GHC.Name, Loc)+import Data.Tree (Forest, Tree (..)) -data Collect = Collect-  { _decls :: [GHCDecl],-    _uses :: [(GHC.RealSrcLoc, GHCKey)],-    _types :: EnumMap GHCKey (EnumSet GHCKey)+-- | 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:+-- This happens, for example, with default methods; the name refers to both the method name and the default implementation's name.+-- We have to account for that to _some_ degree, which is why keys is a set.+-- The actual resolution of these happens wit 'dedup' in mkForest+data RawDecl = RawDecl+  { _rdName :: !String,+    rdKeys :: !(EnumSet GHCKey),+    _rdTyp :: !DeclType,+    rdStart :: !Loc,+    rdEnd :: !Loc   } -newtype ParseError = TreeError (TreeError GHC.RealSrcLoc (DeclType, Name, Loc))+data ParseError = TreeError+  { _peModuleName :: String,+    _peModulePath :: FilePath,+    _peError :: TreeError Loc RawDecl+  }  ppParseError :: Prints ParseError-ppParseError (TreeError err) = ppTreeError err+ppParseError (TreeError str path err) = do+  strLn $ "Parse error in module " <> str <> " (" <> path <> ")"+  indent $ ppTreeError err   where-    ppTreeError :: Prints (TreeError GHC.RealSrcLoc (DeclType, Name, Loc))-    ppTreeError (InvalidBounds l (ty, nm, _) r) = strLn "Invalid bounds:" >> indent (ppLocNode l r ty nm)-    ppTreeError (OverlappingBounds (ty, nm, _) (ty', nm', _) l r) = do-      strLn $ "OverlappingBounds bounds: (" <> show (l, r) <> ")"-      indent $ do-        strLn $ showName nm <> " (" <> show ty <> ")"-        strLn $ showName nm' <> " (" <> show ty' <> ")"+    ppTreeError :: Prints (TreeError Loc RawDecl)+    ppTreeError (InvalidBounds l decl r) = do+      strLn $ "Invalid bounds " <> show (l, r) <> "while inserting"+      indent $ ppRawDecl decl+    ppTreeError (OverlappingBounds a b l r) = do+      strLn $ "Clashing bounds: (" <> show (l, r) <> ")"+      strLn "Node 1:"+      indent $ ppRawDecl a+      strLn "Node 2:"+      indent $ ppRawDecl b     ppTreeError MidSplit = strLn "MidSplit"-    ppTreeError (LexicalError l (ty, nm, _) r t) = do-      strLn "Lexical error"+    ppTreeError (LexicalError l decl r t) = do+      strLn "Lexical error while inserting"+      strLn "Node:"+      indent $ ppRawDecl decl+      strLn "Bounds:"+      indent $ showLn (l, r)+      strLn "Tree:"       indent $ do-        ppLocNode l r ty nm         ppLexTree t -showName :: Name -> String-showName (Name name keys) = name <> "    " <> show (EnumSet.toList keys)--ppLocNode :: GHC.RealSrcLoc -> GHC.RealSrcLoc -> DeclType -> Name -> Printer ()-ppLocNode l r typ name = strLn $ showName name <> " (" <> show typ <> ") " <> show l <> " " <> show r+ppRawDecl :: Prints RawDecl+ppRawDecl (RawDecl name keys typ st end) = do+  strLn name+  indent $ do+    strLn $ "Type: " <> show typ+    strLn $ "Span: " <> show (st, end)+    strLn $ "Keys: " <> unwords (show <$> EnumSet.toList keys) -ppLexTree :: Prints (LexTree GHC.RealSrcLoc (DeclType, Name, Loc))-ppLexTree = foldLexTree (pure ()) $ \ls l (typ, name, _loc) m r rs -> do+ppLexTree :: Prints (LexTree Loc RawDecl)+ppLexTree = foldLexTree (pure ()) $ \ls l decl m r rs -> do   ls-  ppLocNode l r typ name+  showLn (l, r)+  ppRawDecl decl   indent m   rs --- A single symbol can apparently declare a name multiple times in the same place, with multiple distinct keys D:-data Name = Name-  { _nameString :: String,-    nameKeys :: EnumSet GHCKey-  }-  deriving (Eq, Ord)--mkName :: GHC.Name -> Name-mkName nm = Name (GHC.getOccString nm) (EnumSet.singleton $ ghcNameKey nm)- ghcNameKey :: GHC.Name -> GHCKey ghcNameKey = GHCKey . GHC.getKey . GHC.nameUnique --- TODO rename, clean up-newtype ParsePhaseDebugInfo = ParsePhaseDebugInfo-  { modulesLexTrees :: [(String, LexTree GHC.RealSrcLoc (DeclType, Name, Loc))]-  }+newtype ParsePhaseDebugInfo = ParsePhaseDebugInfo {modulesLexTrees :: [(String, LexTree Loc RawDecl)]}  ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo ppParsePhaseDebugInfo (ParsePhaseDebugInfo mods) = forM_ mods $ \(modName, ltree) -> do@@ -125,122 +115,154 @@     _pfDecls :: Forest Decl,     _pfCalls :: Set (GHCKey, GHCKey),     _pfTypings :: EnumMap GHCKey (EnumSet GHCKey),-    _pfDebugTree :: LexTree GHC.RealSrcLoc (DeclType, Name, Loc)+    _pfDebugTree :: LexTree Loc RawDecl   } +-- | Assigns and maintains a mapping of GHCKeys to Key+type HieParse a = StateT (Key, EnumMap GHCKey Key) (Either ParseError) a+ parseHieFiles ::   [GHC.HieFile] ->   Either ParseError (ParsePhaseDebugInfo, CallGraph)-parseHieFiles files = do-  (parsed, (_, keymap)) <- runStateT (mapM parseFile files) (0, mempty)-  let (mods, debugs, calls, typings) = unzip4 (fmap (\(ParsedFile name path forest call typing ltree) -> (Module name path forest, (name, ltree), call, typing)) parsed)-      typeEdges = rekeyCalls keymap . Set.fromList $ do-        (term, types) <- EnumMap.toList (mconcat typings)-        typ <- EnumSet.toList types-        pure (term, typ)-  pure (ParsePhaseDebugInfo debugs, CallGraph mods (rekeyCalls keymap (mconcat calls)) typeEdges)+parseHieFiles files = (\(parsed, (_, keymap)) -> mkCallGraph parsed keymap) <$> runStateT (mapM parseHieFile files) (Key 0, mempty)   where-    parseFile ::-      GHC.HieFile ->-      StateT-        (Int, EnumMap GHCKey Key)-        (Either ParseError)-        ParsedFile-    parseFile file@(GHC.HieFile filepath mdl _ _ avails _) = do-      Collect decls uses types <- lift $ collect file-      tree <- lift $ structure decls-      let calls :: Set (GHCKey, GHCKey) = flip foldMap uses $ \(loc, callee) ->-            case LT.lookup loc tree of-              Nothing -> mempty-              Just (_, callerName, _) -> Set.singleton (nameKey callerName, callee)-      let exportKeys = EnumSet.fromList $ fmap ghcNameKey $ avails >>= GHC.availNames-      forest <- rekey exportKeys (deduplicate tree)-      pure $ ParsedFile (GHC.moduleNameString (GHC.moduleName mdl)) filepath forest calls types tree-    nameKey :: Name -> GHCKey-    nameKey = EnumSet.findMin . nameKeys+    mkCallGraph :: [ParsedFile] -> EnumMap GHCKey Key -> (ParsePhaseDebugInfo, CallGraph)+    mkCallGraph parsed keymap =+      let (mods, debugs, calls, typings) = unzip4 (fmap (\(ParsedFile name path decls call typing ltree) -> (Module name path decls, (name, ltree), call, typing)) parsed)+          typeEdges = rekeyCalls keymap . Set.fromList $ do+            (term, types) <- EnumMap.toList (mconcat typings)+            typ <- EnumSet.toList types+            pure (term, typ)+       in (ParsePhaseDebugInfo debugs, CallGraph mods (rekeyCalls keymap (mconcat calls)) typeEdges) -rekey :: forall m. Monad m => EnumSet GHCKey -> NameTree -> StateT (Int, EnumMap GHCKey Key) m (Forest Decl)-rekey exports = go+parseHieFile :: GHC.HieFile -> HieParse ParsedFile+parseHieFile file@(GHC.HieFile filepath mdl _ _ avails _) = do+  lextree <- either (throwError . TreeError modname filepath) pure $ structure decls+  let calls = resolveCalls (fmap (EnumSet.findMin . rdKeys) lextree)+  forest <- forestT (mkDecl exportKeys) (mkForest lextree)+  pure $ ParsedFile modname filepath forest calls types lextree   where-    fresh :: StateT (Int, EnumMap GHCKey Key) m Key-    fresh = state $ \(n, m) -> (Key n, (n + 1, m))-    assoc :: Key -> GHCKey -> StateT (Int, EnumMap GHCKey Key) m ()-    assoc key ghckey = modify $ fmap (EnumMap.insert ghckey key)-    go :: NameTree -> StateT (Int, EnumMap GHCKey Key) m (Forest Decl)-    go (NameTree nt) = forM (Map.toList nt) $ \(name, (ghckeys, typ, sub, mloc)) -> do+    modname = GHC.moduleNameString (GHC.moduleName mdl)+    exportKeys = EnumSet.fromList $ fmap ghcNameKey $ avails >>= GHC.availNames+    Collect decls useSites types = collect file++    resolveCalls :: LexTree Loc GHCKey -> Set (GHCKey, GHCKey)+    resolveCalls lextree = flip foldMap useSites $ \(loc, callee) ->+      case LT.lookup loc lextree of+        Nothing -> mempty+        Just rep -> Set.singleton (rep, callee)++    mkForest :: LexTree Loc RawDecl -> Forest RawDecl+    mkForest = over forestT fromKV . dedup . over forestT toKV . LT.toForest+      where+        toKV (_, RawDecl name keys typ s e, _) = (name, (keys, Max typ, First s, First e))+        fromKV (name, (keys, Max typ, First s, First e)) = RawDecl name keys typ s e++    -- TODO this is the only part that touches the state, maybe it's worth lifting it out+    mkDecl :: EnumSet GHCKey -> RawDecl -> HieParse Decl+    mkDecl exportSet (RawDecl str ghcKeys typ start _) = do       key <- fresh-      forM_ (EnumSet.toList ghckeys) (assoc key)-      sub' <- go sub-      let exported = any (flip EnumSet.member exports) (EnumSet.toList ghckeys)-      pure $ Tree.Node (Decl name key ghckeys exported typ mloc) sub'+      forM_ (EnumSet.toList ghcKeys) (assoc key)+      let exported = any (flip EnumSet.member exportSet) (EnumSet.toList ghcKeys)+      pure $ Decl str key ghcKeys exported typ start -newtype NameTree = NameTree (Map String (EnumSet GHCKey, DeclType, NameTree, Loc))+    fresh :: HieParse Key+    fresh = state $ \(Key n, m) -> (Key n, (Key (n + 1), m)) -instance Semigroup NameTree where-  NameTree ta <> NameTree tb = NameTree $ Map.unionWith f ta tb-    where-      f (ks, typ, sub, loc) (ks', _, sub', _) = (ks <> ks', typ, sub <> sub', loc)+    assoc :: Key -> GHCKey -> HieParse ()+    assoc key ghckey = modify $ fmap (EnumMap.insert ghckey key) -instance Monoid NameTree where mempty = NameTree mempty+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))) -deduplicate :: LexTree GHC.RealSrcLoc (DeclType, Name, Loc) -> NameTree-deduplicate = LT.foldLexTree mempty $ \l _ (typ, Name str ks, mloc) sub _ r ->-  let this = NameTree $ Map.singleton str (ks, typ, sub, mloc)-   in l <> this <> r+newtype Dedup k v = Dedup {unDedup :: Map k (v, Dedup k v)} -structure :: [GHCDecl] -> Either ParseError (LexTree GHC.RealSrcLoc (DeclType, Name, Loc))-structure =-  foldM-    (\t (ty, sp, na, mloc) -> first TreeError $ LT.insertWith f (GHC.realSrcSpanStart sp) (ty, mkName na, mloc) (GHC.realSrcSpanEnd sp) t)-    LT.emptyLexTree+instance (Ord k, Semigroup v) => Semigroup (Dedup k v) where+  Dedup a <> Dedup b = Dedup (Map.unionWith (<>) a b)++structure :: [RawDecl] -> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)+structure = foldM (\ !t decl -> LT.insertWith f (rdStart decl) decl (rdEnd decl) t) LT.emptyLexTree   where-    f (ta, Name na ka, mloc) (tb, Name nb kb, _)-      | ta == tb && na == nb = Just (ta, Name na (ka <> kb), mloc)+    f (RawDecl na ka ta sa ea) (RawDecl nb kb tb _ _)+      | ta == tb && na == nb = Just (RawDecl na (ka <> kb) ta sa ea)       | otherwise = Nothing -spanToLoc :: GHC.RealSrcSpan -> Loc-spanToLoc spn = Loc (GHC.srcSpanStartLine spn) (GHC.srcSpanStartCol spn)- -- | This is the best way I can find of checking whether the name was written by a programmer or not. -- GHC internally classifies names extensively, but none of those mechanisms seem to allow to distinguish GHC-generated names. isGenerated :: GHC.Name -> Bool isGenerated = elem '$' . GHC.getOccString -collect :: GHC.HieFile -> Either ParseError Collect-collect (GHC.HieFile _ _ typeArr (GHC.HieASTs asts) _ _) = execStateT (forT_ traverse asts collect') (Collect mempty mempty mempty)+data Collect = Collect+  { _decls :: [RawDecl],+    _uses :: [(Loc, GHCKey)],+    _types :: EnumMap GHCKey (EnumSet GHCKey)+  }++-- | Collect declarations, uses, and types in a HIE file+collect :: GHC.HieFile -> Collect+collect (GHC.HieFile _ _ typeArr (GHC.HieASTs asts) _ _) = execState (forT_ traverse asts go) (Collect mempty mempty mempty)   where-    tellDecl :: GHCDecl -> StateT Collect (Either ParseError) ()-    tellDecl decl = modify $ \(Collect decls uses types) -> Collect (decl : decls) uses types+    tellDecl :: GHC.Name -> DeclType -> GHC.RealSrcSpan -> State Collect ()+    tellDecl nm typ spn = modify $ \(Collect decls uses types) -> Collect (decl : decls) uses types+      where+        decl =+          RawDecl+            (GHC.getOccString nm)+            (EnumSet.singleton . ghcNameKey $ nm)+            typ+            (Loc (GHC.srcSpanStartLine spn) (GHC.srcSpanStartCol spn))+            (Loc (GHC.srcSpanEndLine spn) (GHC.srcSpanEndCol spn)) -    tellUse :: GHC.RealSrcLoc -> GHCKey -> StateT Collect (Either ParseError) ()-    tellUse loc key = modify $ \(Collect decls uses types) -> Collect decls ((loc, key) : uses) types+    tellUse :: GHC.RealSrcLoc -> GHCKey -> State Collect ()+    tellUse loc key = modify $ \(Collect decls uses types) -> Collect decls ((Loc (GHC.srcLocLine loc) (GHC.srcLocCol loc), key) : uses) types -    tellType :: GHC.Name -> GHC.TypeIndex -> StateT Collect (Either ParseError) ()+    tellType :: GHC.Name -> GHC.TypeIndex -> State Collect ()     tellType name ix = modify $ \(Collect decls uses types) -> Collect decls uses (EnumMap.insertWith (<>) (ghcNameKey name) (typeMap EnumMap.! ix) types)      typeMap = resolveTypes typeArr -    collect' :: GHC.HieAST GHC.TypeIndex -> StateT Collect (Either ParseError) ()-    collect' node@(GHC.Node _ _ children) =+    ignoreNode nodeInfo = any ($ nodeInfo) [isInstanceNode, isTypeSignatureNode, isInlineNode, isMinimalNode, isDerivingNode]++    go :: GHC.HieAST GHC.TypeIndex -> State Collect ()+    go node@(GHC.Node _ _ children) =       forT_ sourceInfo node $ \nodeInfo ->-        if any ($ nodeInfo) [isInstanceNode, isTypeSignatureNode, isInlineNode, isMinimalNode, isDerivingNode]-          then pure ()-          else do-            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-                      IdnIgnore -> pure ()-                      IdnUse -> tellUse (GHC.realSrcSpanStart $ GHC.nodeSpan node) (ghcNameKey name)-                      IdnDecl typ sp-                        | GHC.isPointSpan sp -> pure ()-                        | otherwise -> tellDecl (typ, sp, name, spanToLoc sp)-              _ -> pure ()-            mapM_ collect' children+        unless (ignoreNode nodeInfo) $ do+          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+                IdnIgnore -> pure ()+                IdnUse -> tellUse (GHC.realSrcSpanStart $ GHC.nodeSpan node) (ghcNameKey name)+                IdnDecl typ sp+                  | GHC.isPointSpan sp -> pure ()+                  | otherwise -> tellDecl name typ sp+            _ -> pure ()+          mapM_ go children +-- TODO This can be faster by storing intermediate restuls, but that has proven tricky to get right.+resolveTypes :: Array GHC.TypeIndex GHC.HieTypeFlat -> EnumMap GHC.TypeIndex (EnumSet GHCKey)+resolveTypes typeArray = EnumMap.fromList [(ix, evalState (go ix) mempty) | ix <- Array.indices typeArray]+  where+    keys :: GHC.HieType a -> EnumSet GHCKey+    keys (GHC.HTyConApp (GHC.IfaceTyCon name _) _) = EnumSet.singleton (ghcNameKey name)+    keys (GHC.HForAllTy ((name, _), _) _) = EnumSet.singleton (ghcNameKey name)+    -- These are variables, which we ignore, but it can't hurt+    keys (GHC.HTyVarTy name) = EnumSet.singleton (ghcNameKey name)+    keys _ = mempty+    go :: GHC.TypeIndex -> State (EnumSet GHC.TypeIndex) (EnumSet GHCKey)+    go current =+      gets (EnumSet.member current) >>= \case+        True -> pure mempty+        False -> do+          modify (EnumSet.insert current)+          let ty = typeArray Array.! current+          mappend (keys ty) . mconcat <$> mapM go (Foldable.toList ty)+ data IdentifierType-  = IdnDecl DeclType GHC.Span+  = IdnDecl !DeclType !GHC.Span   | IdnUse   | IdnIgnore @@ -248,7 +270,7 @@   IdnIgnore <> a = a   IdnUse <> IdnIgnore = IdnUse   IdnUse <> a = a-  IdnDecl typ sp <> IdnDecl typ' sp' = IdnDecl (max typ typ') (spanSpans sp sp')+  IdnDecl typ sp <> IdnDecl typ' sp' = IdnDecl (max typ typ') (mergeSpans sp sp')   IdnDecl typ sp <> _ = IdnDecl typ sp  instance Monoid IdentifierType where mempty = IdnIgnore

@@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-}  -- | Rendering takes a callgraph, and produces a dot file-module Calligraphy.Phases.Render (render, pRenderConfig, RenderConfig) where+module Calligraphy.Phases.Render (render, pRenderConfig, RenderConfig (..)) where  import Calligraphy.Util.Printer import Calligraphy.Util.Types

@@ -23,6 +23,7 @@     insert,     emptyLexTree,     foldLexTree,+    toForest,     insertWith,     height,     toList,@@ -32,6 +33,7 @@ where  import Control.Applicative+import Data.Tree (Forest, Tree (..))  data LexTree p a   = Tip@@ -85,6 +87,11 @@  emptyLexTree :: LexTree p a emptyLexTree = Tip++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  {-# INLINE height #-} height :: LexTree p a -> Int

@@ -46,5 +46,10 @@ strLn :: MonadPrint m => String -> m () strLn = line . TB.fromString +{-# INLINE textLn #-} textLn :: MonadPrint m => Text -> m () textLn = line . TB.fromText++{-# INLINE showLn #-}+showLn :: (MonadPrint m, Show a) => a -> m ()+showLn = strLn . show

@@ -20,6 +20,7 @@     forT_,     modForest,     modDecls,+    forestT,   ) where @@ -76,20 +77,25 @@     (Eq, Ord, Show)  data Loc = Loc-  { locLine :: Int,-    locCol :: Int+  { locLine :: !Int,+    locCol :: !Int   }+  deriving (Eq, Ord) +instance Show Loc where+  showsPrec _ (Loc ln col) = shows ln . showChar ':' . shows col+ {-# INLINE modDecls #-} modDecls :: Traversal' Module Decl-modDecls = modForest . traverse . traverse+modDecls = modForest . forestT  {-# INLINE modForest #-} modForest :: Traversal' Module (Forest Decl) modForest f (Module nm fp ds) = Module nm fp <$> f ds -instance Show Loc where-  showsPrec _ (Loc ln col) = shows ln . showChar ':' . shows col+{-# INLINE forestT #-}+forestT :: Traversal (Forest a) (Forest b) a b+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