{-# 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 -> IO Counters
getCounters DynFlags
dynFlags =
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (DynFlags -> HieFile -> Counters
hieFileToCounters DynFlags
dynFlags) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [HieFile]
getHieFiles

hieFileToCounters :: DynFlags
                  -> HieFile
                  -> Counters
hieFileToCounters :: DynFlags -> HieFile -> Counters
hieFileToCounters DynFlags
dynFlags HieFile
hieFile =
  let hies :: HieASTs Int
hies = HieFile -> HieASTs Int
hie_asts HieFile
hieFile
      asts :: Map HiePath (HieAST Int)
asts = forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs Int
hies
      types :: Array Int HieTypeFlat
types = HieFile -> Array Int HieTypeFlat
hie_types HieFile
hieFile
      fullHies :: HieASTs HieTypeFix
fullHies = forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Array Int HieTypeFlat -> HieTypeFix
recoverFullType Array Int HieTypeFlat
types forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieASTs Int
hies
      sourceLines :: [ByteString]
sourceLines = ByteString -> [ByteString]
BS.lines forall a b. (a -> b) -> a -> b
$ HieFile -> ByteString
hie_hs_src HieFile
hieFile
      numLines :: Int
numLines = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
sourceLines
      source :: Array Int ByteString
source = forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0, Int
numLines forall a. Num a => a -> a -> a
- Int
1) [ByteString]
sourceLines

   in ( forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall m a. Monoid m => (HieAST a -> m) -> HieAST a -> m
foldNodeChildren (forall a. Array Int ByteString -> HieAST a -> DefCounter
declLines Array Int ByteString
source)) Map HiePath (HieAST Int)
asts
      , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall m a. Monoid m => (HieAST a -> m) -> HieAST a -> m
foldNodeChildren forall a. HieAST a -> UsageCounter
usageCounter) Map HiePath (HieAST Int)
asts
      , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (DynFlags -> HieAST HieTypeFix -> SigMap
mkSigMap DynFlags
dynFlags) forall a b. (a -> b) -> a -> b
$ forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs HieTypeFix
fullHies
      , forall a. a -> Sum a
Sum Int
numLines
      )

getHieFiles :: IO [HieFile]
getHieFiles :: IO [HieFile]
getHieFiles = do
  [Char]
hieDir <- forall a. a -> Maybe a -> a
fromMaybe [Char]
".hie" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HIE_DIR"
  [[Char]]
filePaths <- [Char] -> IO [[Char]]
getHieFilesIn [Char]
hieDir
    forall a b. IO a -> IO b -> IO a
`onException` do
      [Char] -> IO ()
putStrLn ([Char]
"HIE file directory does not exist: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
hieDir)
      forall a. IO a
exitFailure
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
filePaths) forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"No HIE files found in dir: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
hieDir
    forall a. IO a
exitFailure
  [HieFile]
hieFiles <- [[Char]] -> IO [HieFile]
hieFilesFromPaths [[Char]]
filePaths
  let srcFileExists :: HieFile -> IO Bool
srcFileExists = [Char] -> IO Bool
doesPathExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> [Char]
hie_hs_file
  forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM HieFile -> IO Bool
srcFileExists [HieFile]
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 :: [[Char]] -> IO [HieFile]
hieFilesFromPaths [[Char]]
filePaths = do
  IORef NameCache
nameCacheRef <- forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NameCache
mkNameCache
  let updater :: NameCacheUpdater
updater = (forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
nameCacheRef
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NameCacheUpdater -> [Char] -> IO HieFile
getHieFile NameCacheUpdater
updater) [[Char]]
filePaths

getHieFile :: NameCacheUpdater -> FilePath -> IO HieFile
getHieFile :: NameCacheUpdater -> [Char] -> IO HieFile
getHieFile NameCacheUpdater
ncUpdater [Char]
filePath =
  forall a. [Char] -> Either HieHeader a -> IO a
handleHieVersionMismatch [Char]
filePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HieFileResult -> HieFile
hie_file_result
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (HieHeader -> Bool)
-> NameCacheUpdater
-> [Char]
-> IO (Either HieHeader HieFileResult)
readHieFileWithVersion
          (\(Integer
v, ByteString
_) -> Integer
v forall a. Eq a => a -> a -> Bool
== Integer
hieVersion)
          NameCacheUpdater
ncUpdater
          [Char]
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 :: forall a. [Char] -> Either HieHeader a -> IO a
handleHieVersionMismatch [Char]
path = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {b} {b}. Show a => (a, b) -> IO b
errMsg forall (f :: * -> *) a. Applicative f => a -> f a
pure where
  errMsg :: (a, b) -> IO b
errMsg (a
ver, b
_ghcVer) = do
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
      [ [Char]
"Incompatible hie file: " forall a. Semigroup a => a -> a -> a
<> [Char]
path
      , [Char]
"hie files must be generated with the same GHC version used to compile inventory"
      , [Char]
"Inventory was compiled with GHC version " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Integer
hieVersion
      , [Char]
"The hie files for this project were generated with version " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
ver
      ]
    forall a. IO a
exitFailure

mkNameCache :: IO NameCache
mkNameCache :: IO NameCache
mkNameCache = do
#if MIN_VERSION_ghc(9,4,0)
  initNameCache 'z' []
#else
  UniqSupply
uniqueSupply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'z'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
uniqueSupply []
#endif

-- | Recursively search for .hie files in given directory
getHieFilesIn :: FilePath -> IO [FilePath]
-- ignore Paths_* files generated by cabal
getHieFilesIn :: [Char] -> IO [[Char]]
getHieFilesIn [Char]
path | forall a. Int -> [a] -> [a]
take Int
6 [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"Paths_" = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
getHieFilesIn [Char]
path = do
  Bool
exists <-
    [Char] -> IO Bool
doesPathExist [Char]
path

  if Bool
exists
    then do
      Bool
isFile <- [Char] -> IO Bool
doesFileExist [Char]
path
      if Bool
isFile Bool -> Bool -> Bool
&& [Char]
"hie" [Char] -> [Char] -> Bool
`isExtensionOf` [Char]
path
        then do
          [Char]
path' <- [Char] -> IO [Char]
canonicalizePath [Char]
path
          forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]
path']
        else do
          Bool
isDir <-
            [Char] -> IO Bool
doesDirectoryExist [Char]
path
          if Bool
isDir
            then do
              [[Char]]
cnts <-
                [Char] -> IO [[Char]]
listDirectory [Char]
path
              forall a. [Char] -> IO a -> IO a
withCurrentDirectory [Char]
path (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Char] -> IO [[Char]]
getHieFilesIn [[Char]]
cnts)
            else
              forall (m :: * -> *) a. Monad m => a -> m a
return []
    else
      forall (m :: * -> *) a. Monad m => a -> m a
return []