1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
{-# 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
|
