inventory-0.1.0.2: src/HieFile.hs

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

import           Control.Exception (onException)
import           Control.Monad.State
#if __GLASGOW_HASKELL__ < 900
import           Data.Bifunctor
#endif
import qualified Data.ByteString.Char8 as BS
#if __GLASGOW_HASKELL__ >= 900
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

   in ( foldMap (foldNodeChildren declLines) asts
      , foldMap (foldNodeChildren usageCounter) asts
      , foldMap (mkSigMap dynFlags) $ getAsts fullHies
      , Sum . length . BS.lines $ hie_hs_src hieFile
      )

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 __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
  uniqueSupply <- mkSplitUniqSupply 'z'
  pure $ initNameCache uniqueSupply []

-- | 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 []