From cf2c56c7061b7ed40fdd3b40a352ddb9c9b7371f Mon Sep 17 00:00:00 2001 From: alexwl Date: Tue, 2 Oct 2018 13:17:04 +0300 Subject: Initial commit --- app/Indexer.hs | 208 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 208 insertions(+) create mode 100644 app/Indexer.hs (limited to 'app/Indexer.hs') diff --git a/app/Indexer.hs b/app/Indexer.hs new file mode 100644 index 0000000..083c94d --- /dev/null +++ b/app/Indexer.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +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 (Version(..),showVersion) +import HaskellCodeExplorer.PackageInfo (createPackageInfo) +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 + , strOption + ) +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 + , configPackageDistDirRelativePath :: Maybe FilePath + , configOutputDirectoryName :: Maybe String + , configLog :: !HCE.Log + , configMinLogLevel :: !LogLevel + , configSourceCodePreprocessing :: !HCE.SourceCodePreprocessing + , configCompression :: !Compression + , configGhcOptions :: [String] + , configIgnoreDirectories :: [String] + } deriving (Show, Eq) + +data Compression + = Gzip + | NoCompression + deriving (Show, Eq) + +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +ghcVersion :: Version +ghcVersion = Version {versionBranch = [8, 2, 2, 0], versionTags = []} +#else +ghcVersion :: Version +ghcVersion = Version {versionBranch = [8, 0, 2, 0], versionTags = []} +#endif + +versionInfo :: String +versionInfo = + "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 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 + +configParser :: Parser IndexerConfig +configParser = + IndexerConfig <$> + strOption + (long "package" <> short 'p' <> metavar "PATH" <> + 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 -- cgit v1.2.3