aboutsummaryrefslogtreecommitdiff
path: root/app/Indexer.hs
blob: c145b2ab07da360b4c95b9eb6604478482c788b7 (plain) (blame)
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
{-# 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 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_hcel                    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