{-# LANGUAGE DeriveGeneric, RecordWildCards, GeneralizedNewtypeDeriving, OverloadedStrings #-}
module Hi(
HiKey(), Hi(..), Ident(..),
hiParseDirectory
) where
import qualified Data.HashSet as Set
import qualified Data.HashMap.Lazy as Map
import System.Console.CmdArgs.Verbosity
import System.FilePath
import System.Directory.Extra
import System.Time.Extra
import GHC.Generics
import Data.Tuple.Extra
import Control.Monad
import Control.Exception
import Control.DeepSeq
import Data.Char
import Data.Hashable
import Data.List.Extra
import Data.Semigroup
import Data.Functor
import Util
import qualified Str as S
import System.IO.Extra
import Prelude
data Ident = Ident {identModule :: ModuleName, identName :: IdentName}
deriving (Show,Eq,Ord,Generic)
instance Hashable Ident
instance NFData Ident
data Hi = Hi
{hiModuleName :: ModuleName
,hiImportPackage :: Set.HashSet PackageName
,hiExportIdent :: Set.HashSet Ident
,hiImportIdent :: Set.HashSet Ident
,hiImportModule :: Set.HashSet ModuleName
,hiImportOrphan :: Set.HashSet ModuleName
,hiImportPackageModule :: Set.HashSet (PackageName, ModuleName)
,hiSignatures :: Map.HashMap IdentName (Set.HashSet Ident)
,hiFieldName :: Set.HashSet Ident
} deriving (Show,Eq,Generic)
instance Hashable Hi
instance NFData Hi
instance Semigroup Hi where
x <> y = Hi
{hiModuleName = f (?:) hiModuleName
,hiImportPackage = f (<>) hiImportPackage
,hiExportIdent = f (<>) hiExportIdent
,hiImportIdent = f (<>) hiImportIdent
,hiImportModule = f (<>) hiImportModule
,hiImportPackageModule = f (<>) hiImportPackageModule
,hiImportOrphan = f (<>) hiImportOrphan
,hiSignatures = f (Map.unionWith (<>)) hiSignatures
,hiFieldName = f (<>) hiFieldName
}
where f op sel = sel x `op` sel y
instance Monoid Hi where
mempty = Hi mempty mempty mempty mempty mempty mempty mempty mempty mempty
mappend = (<>)
newtype HiKey = HiKey FilePathEq deriving (Eq,Ord,Hashable)
hiParseDirectory :: FilePath -> IO (Map.HashMap FilePathEq HiKey, Map.HashMap HiKey Hi)
hiParseDirectory dir = do
whenLoud $ putStrLn $ "Reading hi directory " ++ dir
files <- filter ((==) ".dump-hi" . takeExtension) <$> listFilesRecursive dir
his <- forM files $ \file -> do
let name = drop (length dir + 1) file
whenLoud $ do
putStr $ "Reading hi file " ++ name ++ " ... "
hFlush stdout
(time, (len, res)) <- duration $ do
src <- S.readFileUTF8 file
len <- evaluate $ S.length src
let res = trimSignatures $ hiParseContents src
evaluate $ rnf res
return (len, res)
whenLoud $ putStrLn $ S.showLength len ++ " bytes in " ++ showDuration time
return (filePathEq name, res)
let keys = Map.fromList $ map (second HiKey . swap) his
mp1 <- evaluate $ Map.fromList $ map (second (keys Map.!)) his
mp2 <- evaluate $ Map.fromList $ map swap $ Map.toList keys
whenLoud $ putStrLn $ "Found " ++ show (Map.size mp1) ++ " files, " ++ show (Map.size mp2) ++ " distinct"
return (mp1, mp2)
trimSignatures :: Hi -> Hi
trimSignatures hi@Hi{..} = hi{hiSignatures = Map.filterWithKey (\k _ -> k `Set.member` names) hiSignatures}
where names = Set.fromList [s | Ident m s <- Set.toList hiExportIdent, m == hiModuleName]
hiParseContents :: Str -> Hi
hiParseContents = mconcat . map f . parseHanging2 . S.linesCR
where
f (x,xs)
| Just x <- S.stripPrefix "interface " x = mempty{hiModuleName = parseInterface $ S.toList x}
| Just x <- S.stripPrefix "exports:" x = mconcat $ map (parseExports . S.toList) $ unindent2 xs
| Just x <- S.stripPrefix "orphans:" x = mempty{hiImportOrphan = Set.fromList $ map parseInterface $ concatMap (words . S.toList) $ x:xs}
| Just x <- S.stripPrefix "package dependencies:" x = mempty{hiImportPackage = Set.fromList $ map parsePackDep $ concatMap (words . S.toList) $ x:xs}
| Just x <- S.stripPrefix "import " x = case unindent2 xs of
[] | (pkg, mod) <- breakOn ":" $ words (S.toList x) !! 1 -> mempty
{hiImportPackageModule = Set.singleton (parsePackDep pkg, drop 1 mod)}
xs -> let m = words (S.toList x) !! 1 in mempty
{hiImportModule = Set.singleton m
,hiImportIdent = Set.fromList $ map (Ident m . fst . word1 . S.toList) $ dropWhile ("exports:" `S.isPrefixOf`) xs}
| S.length x == S.ugly 32, S.all isHexDigit x,
(y,ys):_ <- parseHanging2 $ map (S.drop $ S.ugly 2) xs,
fun:"::":typ <- concatMap (wordsBy (`elem` (",()[]{} " :: String)) . S.toList) $ y:ys,
not $ "$" `isPrefixOf` fun =
mempty{hiSignatures = Map.singleton fun $ Set.fromList $ map parseIdent typ}
| otherwise = mempty
parsePackDep = intercalate "-" . takeWhile (any isAlpha) . wordsBy (== '-') . takeWhile (/= '@')
parseInterface = takeWhileEnd (/= ':') . fst . word1
parseExports x = mempty
{hiExportIdent = Set.fromList $ y : [Ident (a ?: identModule y) b | Ident a b <- ys]
,hiFieldName = Set.fromList [Ident (identModule y) b | Ident "" b <- ys]
,hiSignatures = Map.fromList [(b, Set.singleton y) | Ident _ b <- ys, b /= identName y]
}
where y:ys = map parseIdent $ wordsBy (`elem` ("{} " :: String)) x
parseIdent x
| isHaskellSymbol $ last x =
let (a,b) = spanEnd isHaskellSymbol x
in if null a then Ident "" b else Ident a $ tail b
| otherwise =
let (a,b) = breakOnEnd "." x
in Ident (if null a then "" else init a) b