mirror of
https://github.com/alexwl/haskell-code-explorer.git
synced 2024-08-17 07:10:30 +03:00
202 lines
6.5 KiB
Haskell
202 lines
6.5 KiB
Haskell
{-# 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 (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
|
|
, 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)
|
|
|
|
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
|