{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Calligraphy (main, mainWithConfig) where import Calligraphy.Compat.Debug (ppHieFile) import qualified Calligraphy.Compat.GHC as GHC import Calligraphy.Phases.DependencyFilter import Calligraphy.Phases.EdgeCleanup import Calligraphy.Phases.NodeFilter import Calligraphy.Phases.Parse import Calligraphy.Phases.Render.Common import Calligraphy.Phases.Render.GraphViz import Calligraphy.Phases.Render.Mermaid import Calligraphy.Phases.Search import Calligraphy.Prelude import Calligraphy.Util.Printer import Calligraphy.Util.Types (ppCallGraph) import Data.IORef import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as Text import Data.Version (showVersion) import Options.Applicative import Paths_calligraphy (version) import System.Directory (findExecutable) import System.Exit import System.IO (stderr) import System.Process main :: IO () main :: IO () main = do AppConfig config <- forall a. ParserInfo a -> IO a execParser forall a b. (a -> b) -> a -> b $ forall a. Parser a -> InfoMod a -> ParserInfo a info (Parser AppConfig pConfig forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b <**> forall a. Parser (a -> a) helper forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b <**> forall a. Parser (a -> a) versionP) forall a. Monoid a => a mempty AppConfig -> IO () mainWithConfig AppConfig config where versionP :: Parser (a -> a) versionP = forall a. FilePath -> Mod OptionFields (a -> a) -> Parser (a -> a) infoOption ( FilePath "calligraphy version " forall a. Semigroup a => a -> a -> a <> Version -> FilePath showVersion Version version forall a. Semigroup a => a -> a -> a <> FilePath "\nhie version " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> FilePath show Integer GHC.hieVersion ) (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "version" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Show version") mainWithConfig :: AppConfig -> IO () mainWithConfig :: AppConfig -> IO () mainWithConfig AppConfig {SearchConfig RenderConfig GraphVizConfig NodeFilterConfig EdgeCleanupConfig DependencyFilterConfig DebugConfig OutputConfig debugConfig :: AppConfig -> DebugConfig outputConfig :: AppConfig -> OutputConfig graphVizConfig :: AppConfig -> GraphVizConfig renderConfig :: AppConfig -> RenderConfig edgeFilterConfig :: AppConfig -> EdgeCleanupConfig dependencyFilterConfig :: AppConfig -> DependencyFilterConfig nodeFilterConfig :: AppConfig -> NodeFilterConfig searchConfig :: AppConfig -> SearchConfig debugConfig :: DebugConfig outputConfig :: OutputConfig graphVizConfig :: GraphVizConfig renderConfig :: RenderConfig edgeFilterConfig :: EdgeCleanupConfig dependencyFilterConfig :: DependencyFilterConfig nodeFilterConfig :: NodeFilterConfig searchConfig :: SearchConfig ..} = do let debug :: (DebugConfig -> Bool) -> Printer () -> IO () debug :: (DebugConfig -> Bool) -> Printer () -> IO () debug DebugConfig -> Bool fp Printer () printer = forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (DebugConfig -> Bool fp DebugConfig debugConfig) (Printer () -> IO () printStderr Printer () printer) [HieFile] hieFiles <- SearchConfig -> IO [HieFile] searchFiles SearchConfig searchConfig forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (forall (t :: * -> *) a. Foldable t => t a -> Bool null [HieFile] hieFiles) forall a b. (a -> b) -> a -> b $ forall a. FilePath -> IO a die FilePath "No files matched your search criteria.." (DebugConfig -> Bool) -> Printer () -> IO () debug DebugConfig -> Bool dumpHieFile forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Prints HieFile ppHieFile [HieFile] hieFiles (ParsePhaseDebugInfo parsePhaseDebug, CallGraph cgParsed) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a. Printer () -> IO a printDie forall b c a. (b -> c) -> (a -> b) -> a -> c . Prints ParseError ppParseError) forall (f :: * -> *) a. Applicative f => a -> f a pure ([HieFile] -> Either ParseError (ParsePhaseDebugInfo, CallGraph) parseHieFiles [HieFile] hieFiles) (DebugConfig -> Bool) -> Printer () -> IO () debug DebugConfig -> Bool dumpLexicalTree forall a b. (a -> b) -> a -> b $ Prints ParsePhaseDebugInfo ppParsePhaseDebugInfo ParsePhaseDebugInfo parsePhaseDebug let cgCollapsed :: CallGraph cgCollapsed = NodeFilterConfig -> CallGraph -> CallGraph filterNodes NodeFilterConfig nodeFilterConfig CallGraph cgParsed CallGraph cgDependencyFiltered <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a. Printer () -> IO a printDie forall b c a. (b -> c) -> (a -> b) -> a -> c . Prints DependencyFilterError ppFilterError) forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ DependencyFilterConfig -> CallGraph -> Either DependencyFilterError CallGraph dependencyFilter DependencyFilterConfig dependencyFilterConfig CallGraph cgCollapsed let cgCleaned :: CallGraph cgCleaned = EdgeCleanupConfig -> CallGraph -> CallGraph cleanupEdges EdgeCleanupConfig edgeFilterConfig CallGraph cgDependencyFiltered (DebugConfig -> Bool) -> Printer () -> IO () debug DebugConfig -> Bool dumpFinal forall a b. (a -> b) -> a -> b $ Prints CallGraph ppCallGraph CallGraph cgCleaned let renderConfig' :: RenderConfig renderConfig' | NodeFilterConfig -> Bool collapseModules NodeFilterConfig nodeFilterConfig = RenderConfig renderConfig {clusterModules :: ClusterModules clusterModules = ClusterModules ClusterNever} | Bool otherwise = RenderConfig renderConfig RenderGraph renderable <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a. Printer () -> IO a printDie forall b c a. (b -> c) -> (a -> b) -> a -> c . Prints RenderError ppRenderError) forall (f :: * -> *) a. Applicative f => a -> f a pure (RenderConfig -> CallGraph -> Either RenderError RenderGraph renderGraph RenderConfig renderConfig' CallGraph cgCleaned) OutputConfig -> Text -> Text -> IO () output OutputConfig outputConfig (Printer () -> Text runPrinter forall a b. (a -> b) -> a -> b $ GraphVizConfig -> Prints RenderGraph renderGraphViz GraphVizConfig graphVizConfig RenderGraph renderable) (Printer () -> Text runPrinter forall a b. (a -> b) -> a -> b $ Prints RenderGraph renderMermaid RenderGraph renderable) data AppConfig = AppConfig { AppConfig -> SearchConfig searchConfig :: SearchConfig, AppConfig -> NodeFilterConfig nodeFilterConfig :: NodeFilterConfig, AppConfig -> DependencyFilterConfig dependencyFilterConfig :: DependencyFilterConfig, AppConfig -> EdgeCleanupConfig edgeFilterConfig :: EdgeCleanupConfig, AppConfig -> RenderConfig renderConfig :: RenderConfig, AppConfig -> GraphVizConfig graphVizConfig :: GraphVizConfig, AppConfig -> OutputConfig outputConfig :: OutputConfig, AppConfig -> DebugConfig debugConfig :: DebugConfig } printStderr :: Printer () -> IO () printStderr :: Printer () -> IO () printStderr = Handle -> Text -> IO () Text.hPutStrLn Handle stderr forall b c a. (b -> c) -> (a -> b) -> a -> c . Printer () -> Text runPrinter printDie :: Printer () -> IO a printDie :: forall a. Printer () -> IO a printDie Printer () txt = Printer () -> IO () printStderr Printer () txt forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall a. IO a exitFailure pConfig :: Parser AppConfig pConfig :: Parser AppConfig pConfig = SearchConfig -> NodeFilterConfig -> DependencyFilterConfig -> EdgeCleanupConfig -> RenderConfig -> GraphVizConfig -> OutputConfig -> DebugConfig -> AppConfig AppConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser SearchConfig pSearchConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser NodeFilterConfig pNodeFilterConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser DependencyFilterConfig pDependencyFilterConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser EdgeCleanupConfig pEdgeCleanupConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser RenderConfig pRenderConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser GraphVizConfig pGraphVizConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser OutputConfig pOutputConfig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser DebugConfig pDebugConfig output :: OutputConfig -> Text -> Text -> IO () output :: OutputConfig -> Text -> Text -> IO () output cfg :: OutputConfig cfg@OutputConfig {FilePath Maybe FilePath StdoutFormat outputStdout :: OutputConfig -> StdoutFormat outputEngine :: OutputConfig -> FilePath outputMermaidPath :: OutputConfig -> Maybe FilePath outputSvgPath :: OutputConfig -> Maybe FilePath outputPngPath :: OutputConfig -> Maybe FilePath outputDotPath :: OutputConfig -> Maybe FilePath outputStdout :: StdoutFormat outputEngine :: FilePath outputMermaidPath :: Maybe FilePath outputSvgPath :: Maybe FilePath outputPngPath :: Maybe FilePath outputDotPath :: Maybe FilePath ..} Text dotTxt Text mermaidTxt = do forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (OutputConfig -> Bool hasOutput OutputConfig cfg) forall a b. (a -> b) -> a -> b $ Handle -> Text -> IO () Text.hPutStrLn Handle stderr Text "Warning: no output options specified, run with --help to see options" IO FilePath getSvg <- forall a. IO a -> IO (IO a) once forall a b. (a -> b) -> a -> b $ [FilePath] -> IO FilePath runDot [FilePath "-Tsvg"] forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ Maybe FilePath outputDotPath forall a b. (a -> b) -> a -> b $ \FilePath fp -> FilePath -> Text -> IO () Text.writeFile FilePath fp Text dotTxt forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ Maybe FilePath outputPngPath forall a b. (a -> b) -> a -> b $ \FilePath fp -> [FilePath] -> IO FilePath runDot [FilePath "-Tpng", FilePath "-o", FilePath fp] forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ Maybe FilePath outputSvgPath forall a b. (a -> b) -> a -> b $ \FilePath fp -> IO FilePath getSvg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= FilePath -> FilePath -> IO () writeFile FilePath fp forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ Maybe FilePath outputMermaidPath forall a b. (a -> b) -> a -> b $ \FilePath fp -> FilePath -> Text -> IO () Text.writeFile FilePath fp Text mermaidTxt case StdoutFormat outputStdout of StdoutFormat StdoutDot -> Text -> IO () Text.putStrLn Text dotTxt StdoutFormat StdoutMermaid -> Text -> IO () Text.putStrLn Text mermaidTxt StdoutFormat StdoutSVG -> IO FilePath getSvg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= FilePath -> IO () putStrLn StdoutFormat StdoutNone -> forall (f :: * -> *) a. Applicative f => a -> f a pure () where hasOutput :: OutputConfig -> Bool hasOutput (OutputConfig Maybe FilePath Nothing Maybe FilePath Nothing Maybe FilePath Nothing Maybe FilePath Nothing FilePath _ StdoutFormat StdoutNone) = Bool False hasOutput OutputConfig _ = Bool True once :: IO a -> IO (IO a) once :: forall a. IO a -> IO (IO a) once IO a act = do IORef (Maybe a) ref <- forall a. a -> IO (IORef a) newIORef forall a. Maybe a Nothing forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. IORef a -> IO a readIORef IORef (Maybe a) ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just a a -> forall (f :: * -> *) a. Applicative f => a -> f a pure a a Maybe a Nothing -> do a a <- IO a act forall a. IORef a -> a -> IO () writeIORef IORef (Maybe a) ref (forall a. a -> Maybe a Just a a) forall (f :: * -> *) a. Applicative f => a -> f a pure a a runDot :: [String] -> IO String runDot :: [FilePath] -> IO FilePath runDot [FilePath] flags = do Maybe FilePath mexe <- FilePath -> IO (Maybe FilePath) findExecutable FilePath outputEngine case Maybe FilePath mexe of Maybe FilePath Nothing -> forall a. FilePath -> IO a die forall a b. (a -> b) -> a -> b $ FilePath "Unable to find '" forall a. Semigroup a => a -> a -> a <> FilePath outputEngine forall a. Semigroup a => a -> a -> a <> FilePath "' executable! Make sure it is installed, or use another output method/engine." Just FilePath exe -> do (ExitCode code, FilePath out, FilePath err) <- FilePath -> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath) readProcessWithExitCode FilePath exe [FilePath] flags (Text -> FilePath T.unpack Text dotTxt) case ExitCode code of ExitCode ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a pure FilePath out ExitCode _ -> forall a. Printer () -> IO a printDie forall a b. (a -> b) -> a -> b $ do FilePath -> Printer () strLn forall a b. (a -> b) -> a -> b $ FilePath outputEngine forall a. Semigroup a => a -> a -> a <> FilePath " crashed with " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> FilePath show ExitCode code FilePath -> Printer () strLn FilePath "Stdout:" forall a. Printer a -> Printer a indent forall a b. (a -> b) -> a -> b $ FilePath -> Printer () strLn FilePath out FilePath -> Printer () strLn FilePath "Stderr:" forall a. Printer a -> Printer a indent forall a b. (a -> b) -> a -> b $ FilePath -> Printer () strLn FilePath err data StdoutFormat = StdoutNone | StdoutDot | StdoutMermaid | StdoutSVG data OutputConfig = OutputConfig { OutputConfig -> Maybe FilePath outputDotPath :: Maybe FilePath, OutputConfig -> Maybe FilePath outputPngPath :: Maybe FilePath, OutputConfig -> Maybe FilePath outputSvgPath :: Maybe FilePath, OutputConfig -> Maybe FilePath outputMermaidPath :: Maybe FilePath, OutputConfig -> FilePath outputEngine :: String, OutputConfig -> StdoutFormat outputStdout :: StdoutFormat } pOutputConfig :: Parser OutputConfig pOutputConfig :: Parser OutputConfig pOutputConfig = Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> FilePath -> StdoutFormat -> OutputConfig OutputConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional (forall s. IsString s => Mod OptionFields s -> Parser s strOption (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "output-dot" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'd' forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "FILE" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath ".dot output path")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional (forall s. IsString s => Mod OptionFields s -> Parser s strOption (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "output-png" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'p' forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "FILE" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath ".png output path (requires `dot` or other engine in PATH)")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional (forall s. IsString s => Mod OptionFields s -> Parser s strOption (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "output-svg" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 's' forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "FILE" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath ".svg output path (requires `dot` or other engine in PATH)")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional (forall s. IsString s => Mod OptionFields s -> Parser s strOption (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "output-mermaid" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'm' forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "FILE" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Mermaid output path")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall s. IsString s => Mod OptionFields s -> Parser s strOption (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "render-engine" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a metavar FilePath "CMD" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Render engine to use with --output-png and --output-svg" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasValue f => a -> Mod f a value FilePath "dot" forall a. Semigroup a => a -> a -> a <> forall a (f :: * -> *). Show a => Mod f a showDefault) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser StdoutFormat pStdoutFormat pStdoutFormat :: Parser StdoutFormat pStdoutFormat :: Parser StdoutFormat pStdoutFormat = forall a. a -> Mod FlagFields a -> Parser a flag' StdoutFormat StdoutDot (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "stdout-dot" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Output graphviz dot to stdout") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall a. a -> Mod FlagFields a -> Parser a flag' StdoutFormat StdoutMermaid (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "stdout-mermaid" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Output Mermaid to stdout") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall a. a -> Mod FlagFields a -> Parser a flag' StdoutFormat StdoutSVG (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "stdout-svg" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Output SVG to stdout") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall (f :: * -> *) a. Applicative f => a -> f a pure StdoutFormat StdoutNone data DebugConfig = DebugConfig { DebugConfig -> Bool dumpHieFile :: Bool, DebugConfig -> Bool dumpLexicalTree :: Bool, DebugConfig -> Bool dumpFinal :: Bool } pDebugConfig :: Parser DebugConfig pDebugConfig :: Parser DebugConfig pDebugConfig = Bool -> Bool -> Bool -> DebugConfig DebugConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Mod FlagFields Bool -> Parser Bool switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "ddump-hie-file" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Debug dump raw HIE files.") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Mod FlagFields Bool -> Parser Bool switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "ddump-lexical-tree" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Debug dump the reconstructed lexical structure of HIE files, the intermediate output in the parsing phase.") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Mod FlagFields Bool -> Parser Bool switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a long FilePath "ddump-final" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. FilePath -> Mod f a help FilePath "Debug dump the final tree after processing, i.e. as it will be rendered.")