aboutsummaryrefslogtreecommitdiff
path: root/app/Indexer.hs
blob: 6284f0600a9cddc9cbb8e1659d85bbf1d424183b (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
{-# 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, 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