inventory-0.1.0.4: src/HieFile.hs

{-# LANGUAGE CPP #-}
module HieFile
  ( Counters
  , getCounters
  , hieFileToCounters
  , hieFilesFromPaths
  , mkNameCache
  ) where

import           Control.Exception (onException)
import           Control.Monad
import qualified Data.Array as A
#if __GLASGOW_HASKELL__ < 900
import           Control.Monad.State
import           Data.Bifunctor
#endif
import qualified Data.ByteString.Char8 as BS
#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,4,0)
import           Data.IORef
#endif
import           Data.Maybe
import           Data.Monoid
import           System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory)
import           System.Environment (lookupEnv)
import           System.Exit (exitFailure)
import           System.FilePath (isExtensionOf)

import           DefCounts.ProcessHie
import           GHC.Api hiding (hieDir)
import           MatchSigs.ProcessHie
import           UseCounts.ProcessHie
import           Utils

type Counters = ( DefCounter
                , UsageCounter
                , SigMap
                , Sum Int -- total num lines
                )

getCounters :: DynFlags -> IO Counters
getCounters dynFlags =
  foldMap (hieFileToCounters dynFlags) <$> getHieFiles

hieFileToCounters :: DynFlags
                  -> HieFile
                  -> Counters
hieFileToCounters dynFlags hieFile =
  let hies = hie_asts hieFile
      asts = getAsts hies
      types = hie_types hieFile
      fullHies = flip recoverFullType types <$> hies
      sourceLines = BS.lines $ hie_hs_src hieFile
      numLines = length sourceLines
      source = A.listArray (0, numLines - 1) sourceLines

   in ( foldMap (foldNodeChildren (declLines source)) asts
      , foldMap (foldNodeChildren usageCounter) asts
      , foldMap (mkSigMap dynFlags) $ getAsts fullHies
      , Sum numLines
      )

getHieFiles :: IO [HieFile]
getHieFiles = do
  hieDir <- fromMaybe ".hie" <$> lookupEnv "HIE_DIR"
  filePaths <- getHieFilesIn hieDir
    `onException` do
      putStrLn ("HIE file directory does not exist: " <> show hieDir)
      exitFailure
  when (null filePaths) $ do
    putStrLn $ "No HIE files found in dir: " <> show hieDir
    exitFailure
  hieFiles <- hieFilesFromPaths filePaths
  let srcFileExists = doesPathExist . hie_hs_file
  filterM srcFileExists hieFiles

#if MIN_VERSION_ghc(9,4,0)

hieFilesFromPaths :: [FilePath] -> IO [HieFile]
hieFilesFromPaths filePaths = do
  nameCache <- mkNameCache
  traverse (getHieFile nameCache) filePaths

getHieFile :: NameCache -> FilePath -> IO HieFile
getHieFile nameCache filePath =
  handleHieVersionMismatch filePath . fmap hie_file_result
    =<< readHieFileWithVersion
          (\(v, _) -> v == hieVersion)
          nameCache
          filePath

#elif __GLASGOW_HASKELL__ >= 900

hieFilesFromPaths :: [FilePath] -> IO [HieFile]
hieFilesFromPaths filePaths = do
  nameCacheRef <- newIORef =<< mkNameCache
  let updater = NCU $ atomicModifyIORef' nameCacheRef
  traverse (getHieFile updater) filePaths

getHieFile :: NameCacheUpdater -> FilePath -> IO HieFile
getHieFile ncUpdater filePath =
  handleHieVersionMismatch filePath . fmap hie_file_result
    =<< readHieFileWithVersion
          (\(v, _) -> v == hieVersion)
          ncUpdater
          filePath

#else

hieFilesFromPaths :: [FilePath] -> IO [HieFile]
hieFilesFromPaths filePaths = do
  nameCache <- mkNameCache
  evalStateT (traverse getHieFile filePaths) nameCache

getHieFile :: FilePath -> StateT NameCache IO HieFile
getHieFile filePath = StateT $ \nameCache ->
  handleHieVersionMismatch filePath . fmap (first hie_file_result)
    =<< readHieFileWithVersion
          (\(v, _) -> v == hieVersion)
          nameCache
          filePath

#endif

handleHieVersionMismatch :: FilePath -> Either HieHeader a -> IO a
handleHieVersionMismatch path = either errMsg pure where
  errMsg (ver, _ghcVer) = do
    putStrLn $ unlines
      [ "Incompatible hie file: " <> path
      , "hie files must be generated with the same GHC version used to compile inventory"
      , "Inventory was compiled with GHC version " <> show hieVersion
      , "The hie files for this project were generated with version " <> show ver
      ]
    exitFailure

mkNameCache :: IO NameCache
mkNameCache = do
#if MIN_VERSION_ghc(9,4,0)
  initNameCache 'z' []
#else
  uniqueSupply <- mkSplitUniqSupply 'z'
  pure $ initNameCache uniqueSupply []
#endif

-- | Recursively search for .hie files in given directory
getHieFilesIn :: FilePath -> IO [FilePath]
-- ignore Paths_* files generated by cabal
getHieFilesIn path | take 6 path == "Paths_" = pure []
getHieFilesIn path = do
  exists <-
    doesPathExist path

  if exists
    then do
      isFile <- doesFileExist path
      if isFile && "hie" `isExtensionOf` path
        then do
          path' <- canonicalizePath path
          return [path']
        else do
          isDir <-
            doesDirectoryExist path
          if isDir
            then do
              cnts <-
                listDirectory path
              withCurrentDirectory path (foldMap getHieFilesIn cnts)
            else
              return []
    else
      return []