content: {-# 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 Data.Maybe
  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
          -- ^ Module name
      ,hiImportPackage :: Set.HashSet PackageName
          -- ^ Packages imported by this module
      ,hiExportIdent :: Set.HashSet Ident
          -- ^ Identifiers exported by this module
      ,hiImportIdent :: Set.HashSet Ident
          -- ^ Identifiers used by this module
      ,hiImportModule :: Set.HashSet ModuleName
          -- ^ Modules imported and used by this module
          --   Normally equivalent to @Set.map identModule hiImportIdent@, unless a module supplies only instances
      ,hiImportOrphan :: Set.HashSet ModuleName
          -- ^ Orphans that are in scope in this module
      ,hiImportPackageModule :: Set.HashSet (PackageName, ModuleName)
          -- ^ Modules imported from other packages
      ,hiSignatures :: Map.HashMap IdentName (Set.HashSet Ident)
          -- ^ Type signatures of functions defined in this module and the types they refer to
      ,hiFieldName :: Set.HashSet Ident
          -- ^ Things that are field names
      } 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 = (<>)
  
  -- | Don't expose that we're just using the filename internally
  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)
      -- here we try and dedupe any identical Hi modules
      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)
  
  -- note that in some cases we may get more/less internal signatures, so first remove them
  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 = mconcatMap 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 = mconcatMap (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
                  [] | let s = words (S.toList x) !! 1
                     , (pkg, mod) <- fromMaybe ("", s) $ stripInfix ":" s -> mempty
                      {hiImportPackageModule = Set.singleton (parsePackDep pkg, 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
  
          -- "old-locale-1.0.0.7@old-locale-1.0.0.7-KGBP1BSKxH5GCm0LnZP04j" -> "old-locale"
          -- "old-locale-1.0.0.7" -> "old-locale"
          parsePackDep = intercalate "-" . takeWhile (any isAlpha) . wordsBy (== '-') . takeWhile (/= '@')
  
          -- "hlint-1.9.41-IPKy9tGF1918X9VRp9DMhp:HSE.All 8002" -> "HSE.All"
          -- "HSE.All 8002" -> "HSE.All"
          parseInterface = takeWhileEnd (/= ':') . fst . word1
  
          -- "Apply.applyHintFile"
          -- "Language.Haskell.PPHsMode{Language.Haskell.PPHsMode caseIndent}
          -- Return the identifiers and the fields. Fields are never qualified but everything else is.
          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
  
          -- "Language.Haskell.PPHsMode" -> Ident "Language.Haskell" "PPHsMode"
          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
  