diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Indexer.hs | 376 |
1 files changed, 204 insertions, 172 deletions
diff --git a/app/Indexer.hs b/app/Indexer.hs index 88aa7ad..3b357a3 100644 --- a/app/Indexer.hs +++ b/app/Indexer.hs @@ -4,70 +4,79 @@ module Main where -import Codec.Compression.GZip(compress) -import Control.Exception (SomeException, handle) -import Control.Monad (when) -import Control.Monad.Logger (LogLevel(..), runLoggingT) -import qualified Data.Aeson as A -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSC -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) -import qualified Data.Serialize as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Time (getZonedTime) -import Data.Version (showVersion) -import HaskellCodeExplorer.PackageInfo (createPackageInfo, ghcVersion) -import qualified HaskellCodeExplorer.Types as HCE -import Network.URI.Encode (encode) -import Options.Applicative - ( Parser - , (<|>) - , execParser - , flag - , fullDesc - , help - , helper - , info - , long - , many - , metavar - , optional - , progDesc - , short - , showDefault - , strOption - , value - ) -import Paths_haskell_code_explorer as HSE (version) -import System.Directory (createDirectoryIfMissing) -import System.Exit (ExitCode(..), exitWith) -import System.FilePath ((</>)) -import System.Log.FastLogger - ( LoggerSet - , ToLogStr(..) - , defaultBufSize - , fromLogStr - , newFileLoggerSet - , newStdoutLoggerSet - , pushLogStrLn - , rmLoggerSet - ) +import Codec.Compression.GZip ( compress ) +import Control.Exception ( SomeException + , handle + ) +import Control.Monad ( when ) +import Control.Monad.Logger ( LogLevel(..) + , runLoggingT + ) +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSC +import qualified Data.HashMap.Strict as HM +import Data.Maybe ( fromMaybe ) +import Data.Semigroup ( (<>) ) +import qualified Data.Serialize as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time ( getZonedTime ) +import Data.Version ( showVersion ) +import HaskellCodeExplorer.PackageInfo + ( createPackageInfo + , ghcVersion + ) +import qualified HaskellCodeExplorer.Types as HCE +import Network.URI.Encode ( encode ) +import Options.Applicative ( (<|>) + , Parser + , execParser + , flag + , fullDesc + , help + , helper + , info + , long + , many + , metavar + , optional + , progDesc + , short + , showDefault + , strOption + , value + ) +import Paths_haskell_code_explorer as HSE + ( version ) +import System.Directory ( createDirectoryIfMissing ) +import System.Exit ( ExitCode(..) + , exitWith + ) +import System.FilePath ( (</>) ) +import System.Log.FastLogger ( LoggerSet + , ToLogStr(..) + , defaultBufSize + , fromLogStr + , newFileLoggerSet + , newStdoutLoggerSet + , pushLogStrLn + , rmLoggerSet + ) data IndexerConfig = IndexerConfig - { configPackageDirectoryPath :: FilePath + { configPackageDirectoryPath :: FilePath , configPackageDistDirRelativePath :: Maybe FilePath - , configOutputDirectoryName :: Maybe String - , configLog :: !HCE.Log - , configMinLogLevel :: !LogLevel - , configSourceCodePreprocessing :: !HCE.SourceCodePreprocessing - , configCompression :: !Compression - , configGhcOptions :: [String] - , configIgnoreDirectories :: [String] - } deriving (Show, Eq) + , configOutputDirectoryName :: Maybe String + , configLog :: !HCE.Log + , configMinLogLevel :: !LogLevel + , configSourceCodePreprocessing :: !HCE.SourceCodePreprocessing + , configCompression :: !Compression + , configGhcOptions :: [String] + , configIgnoreDirectories :: [String] + } + deriving (Show, Eq) data Compression = Gzip @@ -76,126 +85,149 @@ data Compression versionInfo :: String versionInfo = - "haskell-code-indexer version " ++ - showVersion version ++ ", GHC version " ++ showVersion ghcVersion + "haskell-code-indexer version " + ++ showVersion version + ++ ", GHC version " + ++ showVersion ghcVersion main :: IO () main = do - let description = - "haskell-code-indexer collects and saves information about the source code of a Cabal package. " ++ - versionInfo - config <- - execParser $ - info (helper <*> configParser) (fullDesc <> progDesc description) - loggerSet <- - case configLog config of - HCE.ToFile logfile -> newFileLoggerSet defaultBufSize logfile - HCE.StdOut -> newStdoutLoggerSet defaultBufSize + let + description = + "haskell-code-indexer collects and saves information about the source code of a Cabal package. " + ++ versionInfo + config <- execParser + $ info (helper <*> configParser) (fullDesc <> progDesc description) + loggerSet <- case configLog config of + HCE.ToFile logfile -> newFileLoggerSet defaultBufSize logfile + HCE.StdOut -> newStdoutLoggerSet defaultBufSize let minLogLevel = configMinLogLevel config logger loggerSet minLogLevel LevelInfo versionInfo logger loggerSet minLogLevel LevelDebug $ show config handle - (\(e :: SomeException) -> do - logger loggerSet minLogLevel LevelError (show e) - rmLoggerSet loggerSet - exitWith (ExitFailure 1)) $ do - packageInfo <- - runLoggingT - (createPackageInfo - (configPackageDirectoryPath config) - (configPackageDistDirRelativePath config) - (configSourceCodePreprocessing config) - (configGhcOptions config) - (configIgnoreDirectories config)) - (\_loc _source level msg -> logger loggerSet minLogLevel level msg) - let outputDir = - configPackageDirectoryPath config </> - fromMaybe - HCE.defaultOutputDirectoryName - (configOutputDirectoryName config) - createDirectoryIfMissing False outputDir - logger loggerSet minLogLevel LevelDebug $ "Output directory : " ++ outputDir - BS.writeFile - (outputDir </> HCE.packageInfoBinaryFileName) - (S.encode $ HCE.toCompactPackageInfo packageInfo) - mapM_ - (\(HCE.HaskellModulePath path, modInfo) -> - let (compressFunction, compressExtension) = - case configCompression config of - Gzip -> (compress, ".gz") - NoCompression -> (id, "") - filePath = - outputDir </> - (encode (T.unpack path) ++ ".json" ++ compressExtension) - in BSL.writeFile filePath . compressFunction . A.encode $ modInfo) . - HM.toList $ - HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.ModuleInfo) - BSL.writeFile - (outputDir </> HCE.packageInfoJsonFileName) - (A.encode packageInfo) - BSL.writeFile (outputDir </> "version.txt") (BSC.pack $ showVersion version) - logger loggerSet minLogLevel LevelInfo ("Finished" :: T.Text) - rmLoggerSet loggerSet + (\(e :: SomeException) -> do + logger loggerSet minLogLevel LevelError (show e) + rmLoggerSet loggerSet + exitWith (ExitFailure 1) + ) + $ do + packageInfo <- runLoggingT + (createPackageInfo (configPackageDirectoryPath config) + (configPackageDistDirRelativePath config) + (configSourceCodePreprocessing config) + (configGhcOptions config) + (configIgnoreDirectories config) + ) + (\_loc _source level msg -> logger loggerSet minLogLevel level msg) + let outputDir = configPackageDirectoryPath config </> fromMaybe + HCE.defaultOutputDirectoryName + (configOutputDirectoryName config) + createDirectoryIfMissing False outputDir + logger loggerSet minLogLevel LevelDebug + $ "Output directory : " + ++ outputDir + BS.writeFile (outputDir </> HCE.packageInfoBinaryFileName) + (S.encode $ HCE.toCompactPackageInfo packageInfo) + mapM_ + (\(HCE.HaskellModulePath path, modInfo) -> + let (compressFunction, compressExtension) = + case configCompression config of + Gzip -> (compress, ".gz") + NoCompression -> (id, "") + filePath = + outputDir + </> ( encode (T.unpack path) + ++ ".json" + ++ compressExtension + ) + in BSL.writeFile filePath . compressFunction . A.encode $ modInfo + ) + . HM.toList + $ HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.ModuleInfo) + BSL.writeFile (outputDir </> HCE.packageInfoJsonFileName) + (A.encode packageInfo) + BSL.writeFile (outputDir </> "version.txt") + (BSC.pack $ showVersion version) + logger loggerSet minLogLevel LevelInfo ("Finished" :: T.Text) + rmLoggerSet loggerSet configParser :: Parser IndexerConfig configParser = - IndexerConfig <$> - strOption - (long "package" <> short 'p' <> metavar "PATH" <> value "." <> showDefault <> - help "Path to a Cabal package") <*> - optional - (strOption - (long "dist" <> metavar "RELATIVE_PATH" <> - help "Relative path to a dist directory")) <*> - optional - (strOption - (long "output" <> metavar "DIRECTORY_NAME" <> - help "Output directory (default is '.haskell-code-explorer')")) <*> - (pure HCE.StdOut <|> - (HCE.ToFile <$> - strOption - (long "logfile" <> metavar "PATH" <> - help "Path to a log file (by default log is written to stdout)"))) <*> - flag - LevelInfo - LevelDebug - (long "verbose" <> short 'v' <> help "Write debug information to a log") <*> - flag - HCE.AfterPreprocessing - HCE.BeforePreprocessing - (long "before-preprocessing" <> - help - "Index source code before preprocessor pass (by default source code after preprocessing is indexed)") <*> - flag - Gzip - NoCompression - (long "no-compression" <> - help - "Do not compress json files (by default json files are compressed using gzip)") <*> - many - (strOption - (long "ghc" <> metavar "OPTIONS" <> help "Command-line options for GHC")) <*> - many - (strOption - (long "ignore" <> metavar "DIRECTORY_NAME" <> - help "Directories to ignore (e.g. node_modules)")) + IndexerConfig + <$> strOption + ( long "package" + <> short 'p' + <> metavar "PATH" + <> value "." + <> showDefault + <> help "Path to a Cabal package" + ) + <*> optional + (strOption + (long "dist" <> metavar "RELATIVE_PATH" <> help + "Relative path to a dist directory" + ) + ) + <*> optional + (strOption + (long "output" <> metavar "DIRECTORY_NAME" <> help + "Output directory (default is '.haskell-code-explorer')" + ) + ) + <*> ( pure HCE.StdOut + <|> (HCE.ToFile <$> strOption + (long "logfile" <> metavar "PATH" <> help + "Path to a log file (by default log is written to stdout)" + ) + ) + ) + <*> flag + LevelInfo + LevelDebug + (long "verbose" <> short 'v' <> help + "Write debug information to a log" + ) + <*> flag + HCE.AfterPreprocessing + HCE.BeforePreprocessing + ( long "before-preprocessing" + <> help + "Index source code before preprocessor pass (by default source code after preprocessing is indexed)" + ) + <*> flag + Gzip + NoCompression + ( long "no-compression" + <> help + "Do not compress json files (by default json files are compressed using gzip)" + ) + <*> many + (strOption + (long "ghc" <> metavar "OPTIONS" <> help + "Command-line options for GHC" + ) + ) + <*> many + (strOption + (long "ignore" <> metavar "DIRECTORY_NAME" <> help + "Directories to ignore (e.g. node_modules)" + ) + ) logger :: ToLogStr msg => LoggerSet -> LogLevel -> LogLevel -> msg -> IO () -logger loggerSet minLogLevel logLevel msg = - when (logLevel >= minLogLevel) $ do - time <- getZonedTime - let showLogLevel :: LogLevel -> T.Text - showLogLevel LevelDebug = "[debug]" - showLogLevel LevelInfo = "[info]" - showLogLevel LevelWarn = "[warn]" - showLogLevel LevelError = "[error]" - showLogLevel (LevelOther t) = T.concat ["[",t,"]"] - text = - T.concat - [ T.pack $ show time - , " : " - , showLogLevel logLevel - , " " - , TE.decodeUtf8 . fromLogStr . toLogStr $ msg - ] - pushLogStrLn loggerSet $ toLogStr text +logger loggerSet minLogLevel logLevel msg = when (logLevel >= minLogLevel) $ do + time <- getZonedTime + let showLogLevel :: LogLevel -> T.Text + showLogLevel LevelDebug = "[debug]" + showLogLevel LevelInfo = "[info]" + showLogLevel LevelWarn = "[warn]" + showLogLevel LevelError = "[error]" + showLogLevel (LevelOther t) = T.concat ["[", t, "]"] + text = T.concat + [ T.pack $ show time + , " : " + , showLogLevel logLevel + , " " + , TE.decodeUtf8 . fromLogStr . toLogStr $ msg + ] + pushLogStrLn loggerSet $ toLogStr text |