{-# 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
import Calligraphy.Phases.Search
import Calligraphy.Util.Printer
import Calligraphy.Util.Types (ppCallGraph)
import Control.Monad.RWS
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
NodeFilterConfig
EdgeCleanupConfig
DependencyFilterConfig
DebugConfig
OutputConfig
debugConfig :: AppConfig -> DebugConfig
outputConfig :: AppConfig -> OutputConfig
renderConfig :: AppConfig -> RenderConfig
edgeFilterConfig :: AppConfig -> EdgeCleanupConfig
dependencyFilterConfig :: AppConfig -> DependencyFilterConfig
nodeFilterConfig :: AppConfig -> NodeFilterConfig
searchConfig :: AppConfig -> SearchConfig
debugConfig :: DebugConfig
outputConfig :: OutputConfig
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' = RenderConfig
renderConfig {clusterModules :: Bool
clusterModules = RenderConfig -> Bool
clusterModules RenderConfig
renderConfig Bool -> Bool -> Bool
&& Bool -> Bool
not (NodeFilterConfig -> Bool
collapseModules NodeFilterConfig
nodeFilterConfig)}
      txt :: Text
txt = Printer () -> Text
runPrinter forall a b. (a -> b) -> a -> b
$ RenderConfig -> Prints CallGraph
render RenderConfig
renderConfig' CallGraph
cgCleaned

  OutputConfig -> Text -> IO ()
output OutputConfig
outputConfig Text
txt

data AppConfig = AppConfig
  { AppConfig -> SearchConfig
searchConfig :: SearchConfig,
    AppConfig -> NodeFilterConfig
nodeFilterConfig :: NodeFilterConfig,
    AppConfig -> DependencyFilterConfig
dependencyFilterConfig :: DependencyFilterConfig,
    AppConfig -> EdgeCleanupConfig
edgeFilterConfig :: EdgeCleanupConfig,
    AppConfig -> RenderConfig
renderConfig :: RenderConfig,
    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
-> 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 OutputConfig
pOutputConfig
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser DebugConfig
pDebugConfig

output :: OutputConfig -> Text -> IO ()
output :: OutputConfig -> Text -> IO ()
output cfg :: OutputConfig
cfg@OutputConfig {Bool
FilePath
Maybe FilePath
outputStdout :: OutputConfig -> Bool
outputEngine :: OutputConfig -> FilePath
outputSvgPath :: OutputConfig -> Maybe FilePath
outputPngPath :: OutputConfig -> Maybe FilePath
outputDotPath :: OutputConfig -> Maybe FilePath
outputStdout :: Bool
outputEngine :: FilePath
outputSvgPath :: Maybe FilePath
outputPngPath :: Maybe FilePath
outputDotPath :: Maybe FilePath
..} Text
txt = 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"
  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
txt
  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 ()
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 -> [FilePath] -> IO ()
runDot [FilePath
"-Tsvg", FilePath
"-o", FilePath
fp]
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
outputStdout forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
txt
  where
    hasOutput :: OutputConfig -> Bool
hasOutput (OutputConfig Maybe FilePath
Nothing Maybe FilePath
Nothing Maybe FilePath
Nothing FilePath
_ Bool
False) = Bool
False
    hasOutput OutputConfig
_ = Bool
True

    runDot :: [FilePath] -> IO ()
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
txt)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
code forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ do
            FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
outputEngine forall a. Semigroup a => a -> a -> a
<> FilePath
" crashed:"
            FilePath -> IO ()
putStrLn FilePath
out
            FilePath -> IO ()
putStrLn FilePath
err

data OutputConfig = OutputConfig
  { OutputConfig -> Maybe FilePath
outputDotPath :: Maybe FilePath,
    OutputConfig -> Maybe FilePath
outputPngPath :: Maybe FilePath,
    OutputConfig -> Maybe FilePath
outputSvgPath :: Maybe FilePath,
    OutputConfig -> FilePath
outputEngine :: String,
    OutputConfig -> Bool
outputStdout :: Bool
  }

pOutputConfig :: Parser OutputConfig
pOutputConfig :: Parser OutputConfig
pOutputConfig =
  Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> FilePath
-> Bool
-> 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 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
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"output-stdout" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Output to stdout")

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.")