haskell-code-explorer/app/Indexer.hs
2019-03-23 02:04:01 +03:00

223 lines
7.3 KiB
Haskell

{-# 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
, 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
, 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,6,4,0)
ghcVersion :: Version
ghcVersion = Version {versionBranch = [8, 6, 4, 0], versionTags = []}
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,3,0)
ghcVersion :: Version
ghcVersion = Version {versionBranch = [8, 6, 3, 0], versionTags = []}
#elif MIN_VERSION_GLASGOW_HASKELL(8,4,4,0)
ghcVersion :: Version
ghcVersion = Version {versionBranch = [8, 4, 4, 0], versionTags = []}
#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
ghcVersion :: Version
ghcVersion = Version {versionBranch = [8, 4, 3, 0], versionTags = []}
#elif 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" <> 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