EdgeCleanup.hs

{-# LANGUAGE NamedFieldPuns #-}

-- | 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.Prelude hiding (Decl, Node)
import Calligraphy.Util.Types (CallGraph (CallGraph), Decl (..), DeclType (..), Key, forT_, modForest)
import Control.Monad.State.Strict
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree
import Options.Applicative

data EdgeCleanupConfig = EdgeCleanupConfig
  { cleanDoubles :: Bool,
    cleanLoops :: Bool,
    cleanData :: Bool,
    cleanClass :: Bool
  }

cleanupEdges :: EdgeCleanupConfig -> CallGraph -> CallGraph
cleanupEdges
  EdgeCleanupConfig {cleanDoubles, cleanLoops, cleanData, cleanClass}
  (CallGraph mods calls types) =
    CallGraph mods (cleanLoopsFn calls) (cleanLoopsFn . cleanDoublesFn . cleanDataFn . cleanClassFn $ types)
    where
      cleanLoopsFn = if cleanLoops then Set.filter (uncurry (/=)) else id
      cleanDoublesFn = if cleanDoubles then (Set.\\ calls) else id
      cleanDataFn = if cleanData then (Set.\\ dataEdges) else id
      cleanClassFn = if cleanClass then (Set.\\ classEdges) else id
      dataEdges = execState (forT_ (traverse . modForest . traverse) mods go) mempty
        where
          go :: Tree Decl -> State (Set (Key, Key)) ()
          go (Node (Decl _ k _ _ DataDecl _) children) = void $ (traverse . traverse) (\d -> modify (Set.insert (declKey d, k))) children
          go (Node _ children) = mapM_ go children
      classEdges = execState (forT_ (traverse . modForest . traverse) mods go) mempty
        where
          go :: Tree Decl -> State (Set (Key, Key)) ()
          go (Node (Decl _ k _ _ ClassDecl _) children) = void $ (traverse . traverse) (\d -> modify (Set.insert (declKey d, k))) children
          go (Node _ children) = mapM_ go children

pEdgeCleanupConfig :: Parser EdgeCleanupConfig
pEdgeCleanupConfig =
  EdgeCleanupConfig
    <$> flag True False (long "no-clean-double-edges" <> help "Don't remove type edges when value edges already exist.")
    <*> flag True False (long "no-clean-loops" <> help "Don't remove edges that start and stop at the same node, i.e. simple recursion.")
    <*> flag True False (long "no-clean-data" <> help "Don't remove type edges constructors/records back to the parent data type. These are removed by default because their behavior is unreliable, and they're generally redundant.")
    <*> flag True False (long "no-clean-classes" <> help "Don't remove type edges from class members back to the parent class. These are removed by default because their behavior is unreliable, and they're generally redundant.")