{-# 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.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 =
  (HieFile -> Counters) -> [HieFile] -> Counters
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (DynFlags -> HieFile -> Counters
hieFileToCounters DynFlags
dynFlags) ([HieFile] -> Counters) -> IO [HieFile] -> IO Counters
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 TypeIndex
hies = HieFile -> HieASTs TypeIndex
hie_asts HieFile
hieFile
      asts :: Map FastString (HieAST TypeIndex)
asts = HieASTs TypeIndex -> Map FastString (HieAST TypeIndex)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts HieASTs TypeIndex
hies
      types :: Array TypeIndex HieTypeFlat
types = HieFile -> Array TypeIndex HieTypeFlat
hie_types HieFile
hieFile
      fullHies :: HieASTs HieTypeFix
fullHies = (TypeIndex -> Array TypeIndex HieTypeFlat -> HieTypeFix)
-> Array TypeIndex HieTypeFlat -> TypeIndex -> HieTypeFix
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeIndex -> Array TypeIndex HieTypeFlat -> HieTypeFix
recoverFullType Array TypeIndex HieTypeFlat
types (TypeIndex -> HieTypeFix)
-> HieASTs TypeIndex -> HieASTs HieTypeFix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieASTs TypeIndex
hies

   in ( (HieAST TypeIndex -> DefCounter)
-> Map FastString (HieAST TypeIndex) -> DefCounter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((HieAST TypeIndex -> DefCounter) -> HieAST TypeIndex -> DefCounter
forall m a. Monoid m => (HieAST a -> m) -> HieAST a -> m
foldNodeChildren HieAST TypeIndex -> DefCounter
forall a. HieAST a -> DefCounter
declLines) Map FastString (HieAST TypeIndex)
asts
      , (HieAST TypeIndex -> UsageCounter)
-> Map FastString (HieAST TypeIndex) -> UsageCounter
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((HieAST TypeIndex -> UsageCounter)
-> HieAST TypeIndex -> UsageCounter
forall m a. Monoid m => (HieAST a -> m) -> HieAST a -> m
foldNodeChildren HieAST TypeIndex -> UsageCounter
forall a. HieAST a -> UsageCounter
usageCounter) Map FastString (HieAST TypeIndex)
asts
      , (HieAST HieTypeFix -> SigMap)
-> Map FastString (HieAST HieTypeFix) -> SigMap
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (DynFlags -> HieAST HieTypeFix -> SigMap
mkSigMap DynFlags
dynFlags) (Map FastString (HieAST HieTypeFix) -> SigMap)
-> Map FastString (HieAST HieTypeFix) -> SigMap
forall a b. (a -> b) -> a -> b
$ HieASTs HieTypeFix -> Map FastString (HieAST HieTypeFix)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts HieASTs HieTypeFix
fullHies
      , TypeIndex -> Sum TypeIndex
forall a. a -> Sum a
Sum (TypeIndex -> Sum TypeIndex)
-> (ByteString -> TypeIndex) -> ByteString -> Sum TypeIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> TypeIndex
forall (t :: * -> *) a. Foldable t => t a -> TypeIndex
length ([ByteString] -> TypeIndex)
-> (ByteString -> [ByteString]) -> ByteString -> TypeIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines (ByteString -> Sum TypeIndex) -> ByteString -> Sum TypeIndex
forall a b. (a -> b) -> a -> b
$ HieFile -> ByteString
hie_hs_src HieFile
hieFile
      )

getHieFiles :: IO [HieFile]
getHieFiles :: IO [HieFile]
getHieFiles = do
  [Char]
hieDir <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
".hie" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
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
    IO [[Char]] -> IO Any -> IO [[Char]]
forall a b. IO a -> IO b -> IO a
`onException` [Char] -> IO Any
forall a. HasCallStack => [Char] -> a
error [Char]
"HIE file directory does not exist"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
filePaths) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"No HIE files found in dir: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
hieDir
  [HieFile]
hieFiles <- [[Char]] -> IO [HieFile]
hieFilesFromPaths [[Char]]
filePaths
  let srcFileExists :: HieFile -> IO Bool
srcFileExists = [Char] -> IO Bool
doesPathExist ([Char] -> IO Bool) -> (HieFile -> [Char]) -> HieFile -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> [Char]
hie_hs_file
  (HieFile -> IO Bool) -> [HieFile] -> IO [HieFile]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM HieFile -> IO Bool
srcFileExists [HieFile]
hieFiles

#if __GLASGOW_HASKELL__ >= 900

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

#else

hieFilesFromPaths :: [FilePath] -> IO [HieFile]
hieFilesFromPaths :: [[Char]] -> IO [HieFile]
hieFilesFromPaths [[Char]]
filePaths = do
  NameCache
nameCache <- IO NameCache
mkNameCache
  StateT NameCache IO [HieFile] -> NameCache -> IO [HieFile]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (([Char] -> StateT NameCache IO HieFile)
-> [[Char]] -> StateT NameCache IO [HieFile]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Char] -> StateT NameCache IO HieFile
getHieFile [[Char]]
filePaths) NameCache
nameCache

getHieFile :: FilePath -> StateT NameCache IO HieFile
getHieFile :: [Char] -> StateT NameCache IO HieFile
getHieFile [Char]
filePath = (NameCache -> IO (HieFile, NameCache))
-> StateT NameCache IO HieFile
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((NameCache -> IO (HieFile, NameCache))
 -> StateT NameCache IO HieFile)
-> (NameCache -> IO (HieFile, NameCache))
-> StateT NameCache IO HieFile
forall a b. (a -> b) -> a -> b
$ \NameCache
nameCache ->
  (HieFileResult -> HieFile)
-> (HieFileResult, NameCache) -> (HieFile, NameCache)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HieFileResult -> HieFile
hie_file_result ((HieFileResult, NameCache) -> (HieFile, NameCache))
-> IO (HieFileResult, NameCache) -> IO (HieFile, NameCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameCache -> [Char] -> IO (HieFileResult, NameCache)
readHieFile NameCache
nameCache [Char]
filePath

#endif

mkNameCache :: IO NameCache
mkNameCache :: IO NameCache
mkNameCache = do
  UniqSupply
uniqueSupply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'z'
  NameCache -> IO NameCache
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameCache -> IO NameCache) -> NameCache -> IO NameCache
forall a b. (a -> b) -> a -> b
$ UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
uniqueSupply []

-- | 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 | TypeIndex -> [Char] -> [Char]
forall a. TypeIndex -> [a] -> [a]
take TypeIndex
6 [Char]
path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Paths_" = [[Char]] -> IO [[Char]]
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
          [[Char]] -> IO [[Char]]
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
              [Char] -> IO [[Char]] -> IO [[Char]]
forall a. [Char] -> IO a -> IO a
withCurrentDirectory [Char]
path (([Char] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Char] -> IO [[Char]]
getHieFilesIn [[Char]]
cnts)
            else
              [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else
      [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return []