Index.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
module HieIndexer.Index (indexHieFile) where

import Control.Applicative
import Control.Monad
import qualified Control.Monad.State.Strict as State
import Control.Monad.Writer.Strict as Writer
import Control.Monad.Trans.Maybe
import qualified Data.Array as A
import Data.Char
import Data.Default
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
#if MIN_VERSION_ghc(9,6,0)
import Data.Monoid (First(..), getFirst)
#endif
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vector.Unboxed as Vector
import HieDb.Compat (nameModule_maybe, nameOccName)
import System.Directory
import System.FilePath
import Control.Monad.Extra (findM, whenJust, mapMaybeM)

import qualified GHC
import qualified GHC.Types.Avail as GHC (availNames)
import qualified GHC.Types.Basic as GHC (TupleSort(..))
#if !MIN_VERSION_ghc(9,6,0)
import qualified GHC.Types.Basic as GHC (isPromoted)
#endif
import qualified GHC.Iface.Type as GHC (
  IfaceTyLit(..), IfaceTyConSort(..), IfaceTyCon(..), IfaceTyConInfo(..))
import GHC.Iface.Ext.Utils (generateReferencesMap, emptyNodeInfo, flattenAst)
import GHC.Iface.Ext.Types
import qualified GHC.Types.Name.Occurrence as GHC
import qualified GHC.Types.Name as GHC (isSystemName, nameOccName)
#if MIN_VERSION_ghc(9,6,0)
import qualified GHC.Types.Var as GHC (ForAllTyFlag(..), Specificity(..))
#else
import qualified GHC.Types.Var as GHC (ArgFlag(..), Specificity(..))
#endif
import qualified GHC.Unit.Types as GHC
import qualified GHC.Types.Unique.Set as GHC (mkUniqSet, elementOfUniqSet)
#if !MIN_VERSION_ghc(9,6,0)
import qualified GHC.Unit.Module.Name as GHC (moduleNameFS)
#endif
import qualified GHC.Data.FastString as GHC (FastString, bytesFS, mkFastString)

import Util.Log

import qualified Glean
import Glean.Impl.ConfigProvider ()
import qualified Glean.Schema.Hs.Types as Hs
import qualified Glean.Schema.Src.Types as Src
import Glean.Util.Range
import HieIndexer.Options

{- TODO

- issues with record fields
  - DuplicateRecordFields generates names like $sel:field:Rec
  - weird references to the record constructor from field decls
  - why do we get a ref for the field decl?

- types
  - types on constructors
    - no identType on the ConDec
  - types on methods
    - also no identType?
  - types on refs? not supported by Glass
  - types of foreign imports? Seems missing from Hie

- declarations
  - check that GADT data types work properly, including with record fields
  - class defaults
  - instance methods
  - doing this properly is a lot of work, and it's hard to get this
    info from Hie. A possible way to do this is using the Haddock API:
    Haddock's Interface type has all the ASTs for the declarations
    in addition to the Hie.

- imports
  - import refs contain only ModuleName, not Module. This means we can't
    resolve imports to the correct file for module names that occur in
    multiple packages.
  - modules in the export list should be refs

- map Name to exportedness?

- exclude generated names in a cleaner way

- Glass / codemarkup
  - search by scope
  - should modules be symbols?
  - SymbolKind, Visibility, etc.
  - full signatures for symbols (needs declarations)
  - Haddock docs for symbol
-}

mkModule :: Glean.NewFact m => GHC.Module -> UnitName -> m Hs.Module
mkModule mod unit = do
  modname <- Glean.makeFact @Hs.ModuleName $
    fsToText (GHC.moduleNameFS (GHC.moduleName mod))
  unitname <- Glean.makeFact @Hs.UnitName $
    toUnitName unit $ GHC.moduleUnit mod
  Glean.makeFact @Hs.Module $
    Hs.Module_key modname unitname

-- The Glean unit (used for incremental indexing) is
-- <package>:<module>.  We use this rather than the source file path,
-- because you might move the source file while keeping the module
-- name unchanged.
gleanUnit :: GHC.Module -> Glean.UnitName
gleanUnit mod = ghcUnit <> ":" <> moduleName
  where
    ghcUnit = GHC.bytesFS $ GHC.unitFS $ GHC.moduleUnit mod
    moduleName = GHC.bytesFS $ GHC.moduleNameFS $ GHC.moduleName mod

toUnitName :: UnitName -> GHC.Unit -> Text
toUnitName unitName u = case unitName of
  UnitKey -> t
  UnitId
    | isWiredInUnit u -> t
    | (id, _) <- Text.breakOnEnd "-" t, not (Text.null id) -> Text.init id
    | otherwise -> t
    -- TODO: this is not right for local libraries, which have names like
    -- aeson-pretty-0.8.9-inplace-aeson
  where t = fsToText $ GHC.unitFS u

isWiredInUnit :: GHC.Unit -> Bool
isWiredInUnit = \u -> GHC.toUnitId u `GHC.elementOfUniqSet` wiredInUnitIds
  where
  wiredInUnitIds = GHC.mkUniqSet GHC.wiredInUnitIds

mkName :: Glean.NewFact m => GHC.Name -> Hs.Module -> Hs.NameSort -> m Hs.Name
mkName name mod sort = do
  let occ = nameOccName name
  occFact <- Glean.makeFact @Hs.OccName $
    Hs.OccName_key (fsToText (GHC.occNameFS occ)) (toNamespace occ)
  Glean.makeFact @Hs.Name $
    Hs.Name_key occFact mod sort

srcSpanToSrcRange :: Src.File -> GHC.RealSrcSpan -> Src.Range
srcSpanToSrcRange file sp =
  Src.Range file
    (Glean.Nat $ fromIntegral $ GHC.srcSpanStartLine sp)
    (Glean.Nat $ fromIntegral $ GHC.srcSpanStartCol sp)
    (Glean.Nat $ fromIntegral $ GHC.srcSpanEndLine sp)
    (Glean.Nat $ fromIntegral $ GHC.srcSpanEndCol sp - 1)
    -- GHC.RealSrcSpan is exclusive while Src.Range is inclusive, so
    -- we subtract one from the end column when converting.

fsToText :: GHC.FastString -> Text
fsToText = Text.decodeUtf8 . GHC.bytesFS

toNamespace :: GHC.OccName -> Hs.Namespace
toNamespace occ
  | GHC.isVarOcc occ = Hs.Namespace_var_
  | GHC.isTvOcc occ = Hs.Namespace_tyvar
  | GHC.isTcOcc occ = Hs.Namespace_tycon
  | GHC.isDataOcc occ = Hs.Namespace_datacon
  | otherwise = error "toNamespace"

isRecFieldRef :: RecFieldContext -> Bool
isRecFieldRef RecFieldAssign = True
isRecFieldRef RecFieldMatch = True
isRecFieldRef RecFieldOcc = True
isRecFieldRef _ = False

produceDecl
 :: Glean.NewFact m
 => Map (Glean.IdOf Hs.Name) Hs.SigDecl
 -> Hs.Name
 -> Maybe Hs.Type
 -> ContextInfo
 -> m ()
produceDecl sigMap name maybeTy ctx = case ctx of
  ValBind RegularBind _ _ ->
    Glean.makeFact_ @Hs.ValBind $
      Hs.ValBind_key name maybeTy (Map.lookup (Glean.getId name) sigMap)
  Decl FamDec _ ->
    Glean.makeFact_ @Hs.TypeFamilyDecl $ Hs.TypeFamilyDecl_key name
  Decl SynDec _ ->
    Glean.makeFact_ @Hs.TypeSynDecl $ Hs.TypeSynDecl_key name
  Decl PatSynDec _ ->
    Glean.makeFact_ @Hs.PatSynDecl $ Hs.PatSynDecl_key name
  PatternBind{} ->
    Glean.makeFact_ @Hs.PatBind $ Hs.PatBind_key name maybeTy
  TyVarBind{} ->
    Glean.makeFact_ @Hs.TyVarBind $ Hs.TyVarBind_key name
  -- moved to produceDeclInfo:
  ClassTyDecl{} -> return ()
  RecField{} -> return ()
  Decl DataDec _ -> return ()
  Decl ConDec _ -> return ()
  Decl ClassDec _ -> return ()
  _ -> return ()

produceDeclInfo
  :: forall m . (Monad m, Glean.NewFact m)
  => Src.File
  -> (GHC.RealSrcSpan -> Src.ByteSpan)
  -> (GHC.Name -> m (Maybe Hs.Name))
  -> [DeclInfo]
  -> m (Map (Glean.IdOf Hs.Name) Hs.SigDecl)
produceDeclInfo fileFact toByteSpan getName_ infos =
  fmap snd $ runWriterT $ mapM (runMaybeT . makeDecl) infos
  where
  glean = lift . lift

  -- failure to lookup a Name will cause this DeclInfo to be ignored
  getName name = MaybeT $ lift $ getName_ name

  makeDecl
    :: DeclInfo
    -> MaybeT (WriterT (Map (Glean.IdOf Hs.Name) Hs.SigDecl) m) ()
  makeDecl info =
    case info of
      SigDecl{} -> do
        hsName <- getName info.name
        decl <- glean $ Glean.makeFact @Hs.SigDecl $
          Hs.SigDecl_key hsName (
            Src.FileLocation fileFact (toByteSpan info.span))
        -- collect SigDecls using WriterT
        Writer.tell (Map.singleton (Glean.getId hsName) decl)
      DataDecl{} -> do
        hsName <- getName info.name
        cons <- forM info.constrs $ \con -> do
          hsCName <- getName con.name
          fDecls <- forM con.fields $ \fName -> do
            hsFName <- getName fName
            glean $ Glean.makeFact @Hs.RecordFieldDecl $
              Hs.RecordFieldDecl_key hsFName hsCName
          glean $ Glean.makeFact @Hs.ConstrDecl $
            Hs.ConstrDecl_key hsCName hsName fDecls
        glean $ Glean.makeFact_ @Hs.DataDecl $
          Hs.DataDecl_key hsName cons
      ClassDecl{} -> do
        hsName <- getName info.name
        mDecls <- forM info.methods $ \mName -> do
          hsMName <- getName mName
          glean $ Glean.makeFact @Hs.MethDecl $
            Hs.MethDecl_key hsMName hsName
        defaults <- mapM makeInstBind info.defaults
        decl <- glean $ Glean.makeFact @Hs.ClassDecl $
          Hs.ClassDecl_key hsName mDecls defaults
        forM_ defaults $ \bind ->
          glean $ Glean.makeFact_ @Hs.InstanceBindToDecl $
            Hs.InstanceBindToDecl_key bind
              (Hs.InstanceBindToDecl_decl_class_ decl)
      InstDecl{} -> do
        binds <- mapM makeInstBind info.binds
        decl <- glean $ Glean.makeFact @Hs.InstDecl $
          Hs.InstDecl_key binds
            (Src.FileLocation fileFact (toByteSpan info.span))
        forM_ binds $ \bind ->
          glean $ Glean.makeFact_ @Hs.InstanceBindToDecl $
            Hs.InstanceBindToDecl_key bind
              (Hs.InstanceBindToDecl_decl_inst decl)

  makeInstBind instBind = do
    meth <- getName instBind.method
    glean $ Glean.makeFact @Hs.InstanceBind $
      Hs.InstanceBind_key meth {-(IntMap.lookup instBindTy typeMap)-}
        (Src.FileLocation fileFact (toByteSpan instBind.span))

nat :: Integral a => a -> Glean.Nat
nat = Glean.toNat . fromIntegral

indexTypes
  :: forall m . (MonadFail m, Monad m, Glean.NewFact m)
  => UnitName
  -> A.Array TypeIndex HieTypeFlat
  -> m (IntMap Hs.Type)
indexTypes unit typeArr = foldM go IntMap.empty (A.assocs typeArr)
  where
  go tymap (n,ty) = do
    fact <- mkTy ty
    return (IntMap.insert n fact tymap)
    where
    mkTy ty = case ty of
      HTyVarTy n ->
        Glean.makeFact @Hs.Type $ Hs.Type_key_tyvar $
          fsToText (GHC.occNameFS (GHC.nameOccName n))
      HAppTy a (HieArgs args) -> do
        ta <- get a
        targs <- mapM mkTyArg args
        Glean.makeFact @Hs.Type $ Hs.Type_key_app $ Hs.Type_app_ ta targs
      HLitTy l -> do
        tl <- case l of
          GHC.IfaceNumTyLit i ->
            Glean.makeFact @Hs.LitType $
              Hs.LitType_key_num (nat i)
          GHC.IfaceStrTyLit fs ->
            Glean.makeFact @Hs.LitType $
              Hs.LitType_key_str (fsToText fs)
          GHC.IfaceCharTyLit c ->
            Glean.makeFact @Hs.LitType $
              Hs.LitType_key_chr (nat (ord c))
        Glean.makeFact @Hs.Type $ Hs.Type_key_lit tl
      HForAllTy ((n,k),af) t -> do
        let name = fsToText (GHC.occNameFS (GHC.nameOccName n))
        tt <- get t
        kt <- get k
        let flag = case af of
              GHC.Invisible spec ->
                Hs.ArgFlag_invisible $ case spec of
                  GHC.InferredSpec -> Hs.Specificity_inferred
                  GHC.SpecifiedSpec -> Hs.Specificity_specified
              GHC.Required ->
                Hs.ArgFlag_requird def
        Glean.makeFact @Hs.Type $ Hs.Type_key_forall $
          Hs.Type_forall_ name kt flag tt
      HFunTy w a b -> do
        wt <- get w
        ta <- get a
        tb <- get b
        Glean.makeFact @Hs.Type $ Hs.Type_key_fun $ Hs.Type_fun_ wt ta tb
      HQualTy pred b -> do
        predt <- get pred
        tb <- get b
        Glean.makeFact @Hs.Type $ Hs.Type_key_qual $ Hs.Type_qual_ predt tb
      HCastTy a -> do
        ta <- get a
        Glean.makeFact @Hs.Type $ Hs.Type_key_cast ta
      HCoercionTy -> Glean.makeFact @Hs.Type $ Hs.Type_key_coercion def
      HTyConApp tc (HieArgs xs) -> do
        let info = GHC.ifaceTyConInfo tc
            name = GHC.ifaceTyConName tc
        tcname <- case nameModule_maybe name of
          Nothing -> fail "HTyConApp: internal name"
          Just mod -> do
            namemod <- mkModule mod unit
            mkName name namemod (Hs.NameSort_external def)
        let sort = case GHC.ifaceTyConSort info of
              GHC.IfaceNormalTyCon -> Hs.TyConSort_normal def
              GHC.IfaceTupleTyCon arity ts -> Hs.TyConSort_tuple $
                  Hs.TyConSort_tuple_ (nat arity) $
                    case ts of
                      GHC.BoxedTuple -> Hs.TupleSort_boxed
                      GHC.UnboxedTuple -> Hs.TupleSort_unboxed
                      GHC.ConstraintTuple -> Hs.TupleSort_constraint
              GHC.IfaceSumTyCon arity ->
                Hs.TyConSort_sum $ Hs.TyConSort_sum_ $ nat arity
              GHC.IfaceEqualityTyCon -> Hs.TyConSort_equality def
        tycon <- Glean.makeFact @Hs.TyCon $
          Hs.TyCon_key tcname sort
            (GHC.isPromoted (GHC.ifaceTyConIsPromoted info))
        xs <- mapM mkTyArg xs
        Glean.makeFact @Hs.Type $ Hs.Type_key_tyconapp $
          Hs.Type_tyconapp_ tycon xs

    mkTyArg :: (Bool,TypeIndex) -> m Hs.TypeArg
    mkTyArg (vis,ti) = do
      t <- get ti
      return (Hs.TypeArg vis t)

    get :: TypeIndex -> m Hs.Type
    get a = case IntMap.lookup a tymap of
      Nothing -> fail $ "indexTypes: missing " <> show a
      Just t -> return t

indexHieFile
  :: Glean.Writer
  -> HieIndexerOptions
  -> FilePath
  -> HieFile
  -> IO ()
indexHieFile writer HieIndexerOptions{..} path hie = do
  srcFile <- findSourceFile srcPaths (hie_module hie) (hie_hs_file hie)
  logInfo $ "Indexing: " <> path <> " (" <> srcFile <> ")"
  Glean.writeFacts writer $ Glean.withUnit (gleanUnit smod) $ do
    modfact <- mkModule smod unitName

    let offs = getLineOffsets (hie_hs_src hie)
    let hsFileFS = GHC.mkFastString $ hie_hs_file hie
    let file = maybe id (\p f -> (p <> "/" <> f)) srcPrefix (Text.pack srcFile)
    filefact <- Glean.makeFact @Src.File file
    let fileLines = mkFileLines filefact offs
    Glean.makeFact_ @Src.FileLines fileLines

    when storeSrc $
      Glean.makeFactV_ @Src.FileContent filefact $
        Text.decodeUtf8With lenientDecode (hie_hs_src hie)

    Glean.makeFact_ @Hs.ModuleSource $
      Hs.ModuleSource_key modfact filefact

    typeMap <- indexTypes unitName (hie_types hie)

    let toByteRange = srcRangeToByteRange fileLines (hie_hs_src hie)
        toByteSpan sp
          | GHC.srcSpanEndLine sp >= Vector.length (lineOffsets offs) =
            Src.ByteSpan (Glean.toNat 0) (Glean.toNat 0)
          | otherwise =
            rangeToByteSpan (toByteRange (srcSpanToSrcRange filefact sp))

    let allIds = [ (n, p) | (n, ps) <- Map.toList refmap, p <- ps ]
        declInfo = concat $ fmap getDeclInfos $ getAsts $ hie_asts hie

    -- produce names & declarations
    names <- fmap catMaybes $ forM allIds $ \(ident, (span, dets)) -> if
      | Right name <- ident
      , Just sp <- getBindSpan span (identInfo dets)
      , localOrGlobal name smod
      , GHC.srcSpanFile sp == hsFileFS -> do -- Note [#included source files]
        let byteSpan = toByteSpan sp
        sort <- case nameModule_maybe name of
          Nothing -> return $ Hs.NameSort_internal byteSpan
          Just{} -> return $ Hs.NameSort_external def
        namefact <- mkName name modfact sort
        Glean.makeFact_ @Hs.DeclarationLocation $
          Hs.DeclarationLocation_key namefact filefact byteSpan
        {-
          trace ("decl: " <>
            GHC.occNameString (nameOccName name) <> ": " <>
           show (ppr sp)) $ return ()
        -}
        return $ Just (name, namefact)
      | otherwise -> return Nothing

    -- A map for Names defined in this module
    let
      nameMap :: Map GHC.Name Hs.Name
      nameMap = Map.fromList names

      getName :: Glean.NewFact m => GHC.Name -> m (Maybe Hs.Name)
      getName name =
        case Map.lookup name nameMap of
          Just hsName -> return $ Just hsName
          Nothing -> case nameModule_maybe name of
            Nothing ->
              -- This shouldn't happen, it's probably a bug in the hie file.
              -- But it does happen, so let's not crash.
              return Nothing
            Just m -> do
              mod <- if m == smod then return modfact else mkModule m unitName
              Just <$> mkName name mod (Hs.NameSort_external def)

    sigMap <- produceDeclInfo filefact toByteSpan getName declInfo

    forM_ allIds $ \(ident, (_, dets)) -> if
      | Right name <- ident
      , Just namefact <- Map.lookup name nameMap -> do
        let ty = identType dets >>= \ix -> IntMap.lookup ix typeMap
        mapM_ (produceDecl sigMap namefact ty) (Set.toList (identInfo dets))
      | otherwise -> return ()

    eNames <- mapMaybeM getName (concatMap GHC.availNames (hie_exports hie))

    Glean.makeFact_ @Hs.ModuleDeclarations $ Hs.ModuleDeclarations_key
      modfact (map snd names) eNames

    let refs = Map.fromListWith (Map.unionWith (++))
          [ (ident, Map.singleton kind [span])
          | (ident, (span, dets)) <- allIds,
            Just kind <- map isRef (Set.toList (identInfo dets)),
            case ident of
              Left{} -> True
              Right n ->
                not (GHC.isSystemName n) &&
                -- TODO: we should exclude generated names in a cleaner way
                not (GHC.isDerivedOccName (nameOccName n))
          ]

    refs <- fmap catMaybes $ forM (Map.toList refs) $ \(ident, kindspans) -> do
      refspans <- fmap concat $ forM (Map.toList kindspans) $ \(kind, spans) -> do
        let gleanspans = map toByteSpan spans
        return $ map (Hs.RefSpan kind) gleanspans
      case ident of
        Left modName -> do
          gleanMod <- Glean.makeFact @Hs.ModuleName $
            fsToText (GHC.moduleNameFS modName)
          fmap Just $ Glean.makeFact @Hs.XRef $
            Hs.XRef_key (Hs.RefTarget_modName gleanMod) filefact refspans
        Right name -> do
          maybe_namefact <- getName name
          forM maybe_namefact $ \namefact -> do
            Glean.makeFact @Hs.XRef $
              Hs.XRef_key (Hs.RefTarget_name namefact) filefact refspans

    Glean.makeFact_ @Hs.FileXRefs $ Hs.FileXRefs_key filefact refs

  where
  smod = hie_module hie
  refmap = generateReferencesMap $ getAsts $ hie_asts hie

  localOrGlobal :: GHC.Name -> GHC.Module -> Bool
  localOrGlobal name mod = case nameModule_maybe name of
    Nothing -> True
    Just nameMod
      | nameMod == mod -> True
      | otherwise -> False

  -- returns True if this ContextInfo is a reference
  isRef Use = Just Hs.RefKind_coderef
  isRef (RecField r _) | isRecFieldRef r = Just Hs.RefKind_coderef
  isRef (ValBind InstanceBind _ _) = Just Hs.RefKind_coderef
    -- treat these as refs, not binds
  isRef TyDecl{} = Just Hs.RefKind_tydecl
  isRef (IEThing Export) = Just Hs.RefKind_exportref
  isRef (IEThing _) = Just Hs.RefKind_importref
  isRef _ = Nothing

  -- returns (Just span) if this ContextInfo is a definition
  getBindSpan defaultSpan = getFirst . foldMap (First . goDecl)
    where
    goDecl (ValBind RegularBind _ sp) = sp
    goDecl (PatternBind _ _ sp) = sp <|> Just defaultSpan
    goDecl (Decl _ sp) = sp
    goDecl (RecField r sp) | not (isRecFieldRef r) = sp
    goDecl TyVarBind{} = Just defaultSpan
    goDecl (ClassTyDecl sp) = sp
    goDecl _ = Nothing

-- |
-- Attempt to find the original source file given the hie_hs_src value
-- from the .hie file, the module, and the --src flags provided to the
-- indexer.
--
-- See Note [source file paths]
--
findSourceFile :: NonEmpty Text -> GHC.Module -> FilePath -> IO FilePath
findSourceFile srcPaths mod src = do
  r <- findM doesFileExist
    (fmap ((</> src) . Text.unpack) (NonEmpty.toList spliced))
  cwd <- getCurrentDirectory
  -- normalise because some paths are of the form ./A/B/C.hs
  -- makeRelative because generated files can have absolute paths
  makeRelative cwd . normalise <$> case r of
    Nothing -> do
      logWarning $ "couldn't find src for: " <> src
      return src
    Just f -> return f
  where
  pkg = fsToText (GHC.unitFS (GHC.moduleUnit mod))
  isVer = Text.all (\c -> isDigit c || c == '.')
  pkgNameAndVersion = case break isVer (Text.splitOn "-" pkg) of
    (before, after) -> Text.intercalate "-" (before <> take 1 after)
  spliced = fmap (Text.replace "$PACKAGE" pkgNameAndVersion) srcPaths

{-
Note [source file paths]

We need
- source file paths for src.File facts
- source file contents so that we can create src.FileLines and convert
  line/column to bytespan

A src.File should uniquely determine the hs.Module, and should be
relative to the root of the project we're indexing.

The .hie file contains the file name of the original .hs file as seen
by GHC, together with its contents as a ByteString.

The source file path in the .hie file isn't exactly what we need, for
a few reasons:

1. If the project has multiple packages (with a cabal.project), then
the source file names in the .hie files will be relative to each
package. In that case we need to find the original source file to
generate the `src.File` fact. This is done by passing a @--src@ flag to
the indexer, e.g. @--src '$PACKAGE'@.

2. The path often needs normalising, e.g. it's common to see paths
like ./src/A/B/C.hs

3. Sometimes the file path in the .hie file is absolute, but we need
to make it relative, e.g. the Paths_foo.hs modules generated by Cabal
will have absolute path names like
/a/b/c/dist-newstyle/build/x86_64-linux/ghc-9.4.7/HUnit-1.6.2.0/build/autogen/Paths_HUnit.hs
-}

{-
Note [#included source files]

There might be other source files involved when compiling a module,
e.g. if CPP is being used and the .hs file uses `#include`. We
currently ignore Names that come from another source file (TODO).
-}


data DeclInfo
  = DataDecl {
      name :: GHC.Name,
      constrs :: [ConstrInfo]
    }
  | ClassDecl {
      name :: GHC.Name,
      methods :: [GHC.Name],
      defaults :: [InstanceBindInfo]
    }
  | SigDecl {
      name :: GHC.Name,
      span :: GHC.RealSrcSpan
    }
  | InstDecl {
      binds :: [InstanceBindInfo],
      span :: GHC.RealSrcSpan
    }

data InstanceBindInfo = InstanceBindInfo {
    method :: GHC.Name,
    span :: GHC.RealSrcSpan
    -- TODO: add type. The identifier with context ValBind InstanceBind
    -- doesn't have a type, but there is also a ValBind RegularBind
    -- identifier that does have the type attached.
  }

data ConstrInfo =
  ConstrInfo {
    name :: GHC.Name,
    fields :: [GHC.Name]
  }

getDeclInfos :: HieAST TypeIndex -> [DeclInfo]
getDeclInfos node = snd $ State.runState (go node) []
  where
  go node = do
    visit node
    void $ traverse go node.nodeChildren

  visit node =
    {-
      trace ("node: " <> show (ppr (nodeAnnotations nodeInfo)) <> ": " <> show (ppr (fmap (const ()) (nodeIdentifiers nodeInfo)))) $
    -}
    whenJust hasInfo $ \info ->
      State.modify (info:)
    where

    nodeInfo = getNodeInfo node

    hasInfo
      | isDataDecl nodeInfo,
        [(name,_,_)] <- findIdent dataDeclCtx nodeInfo node =
         Just $ DataDecl {
           name = name,
           constrs = findConstrs node }
      | isClassDecl nodeInfo,
        [(name,_,_)] <- findIdent classDeclCtx nodeInfo node =
         Just $ ClassDecl {
           name = name,
           methods = findMethods node,
           defaults = findInstBinds node }
      | isTypeSig nodeInfo,
        [(name,_,_)] <- findIdent tyDeclCtx nodeInfo node =
         Just $ SigDecl {
           name = name,
           span = nodeSpan node }
      | isInstDecl nodeInfo =
         Just $ InstDecl {
           binds = findInstBinds node,
           span = nodeSpan node }
      | otherwise =
          Nothing

    -- The Name for a decl seems to be a child of the declaration Node
    findIdent ctx ni node =
      concatMap (namesWithContext ctx) $
        map nodeIdentifiers (ni : map getNodeInfo node.nodeChildren)

    findMethods node =
      [ meth
      | n <- node.nodeChildren
      , let ni = getNodeInfo n
      , isMethodDecl ni
      , (meth,_,_) <- findIdent classTyDeclCtx ni n
      ]

    findInstBinds node =
      [ InstanceBindInfo {
          method = meth,
          span = span
        }
      | n <- node.nodeChildren
      , let ni = getNodeInfo n
      , isInstanceBind ni
      , (meth, _ty, ValBind _ _ (Just span))  <- findIdent instBindCtx ni n
      ]

    findConstrs node =
      [ ConstrInfo con (fields n)
      | n <- node.nodeChildren
      , let ni = getNodeInfo n
      , isConstrDecl ni
      , (con,_,_) <- findIdent conDeclCtx ni n
      ]
      where
      -- there are intermediate AST nodes between the constructor and
      -- the fields, so rather than matching the shape exactly let's
      -- just search the whole subtree to find fields.
      fields n =
        [ fld
        | child <- flattenAst n
        , let ni = getNodeInfo child
        , (fld,_,_) <- namesWithContext recFieldDeclCtx (nodeIdentifiers ni)
        ]

namesWithContext
  :: (ContextInfo -> Bool)
  -> NodeIdentifiers a
  -> [(GHC.Name, Maybe a, ContextInfo)]
namesWithContext p ids =
  [ (name, identType dtl, ctx)
  | (Right name, dtl) <- Map.toList ids
  , ctx <- Set.toList (identInfo dtl)
  , p ctx ]

getNodeInfo :: HieAST a -> NodeInfo a
getNodeInfo =
  foldl' combine emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
  where
  (NodeInfo as ai ad) `combine` (NodeInfo bs bi bd) =
    NodeInfo (Set.union as bs) (ai <> bi) (Map.unionWith (<>) ad bd)

dataDeclCtx :: ContextInfo -> Bool
dataDeclCtx (Decl DataDec _) = True
dataDeclCtx _ = False

conDeclCtx :: ContextInfo -> Bool
conDeclCtx (Decl ConDec _) = True
conDeclCtx _ = False

recFieldDeclCtx :: ContextInfo -> Bool
recFieldDeclCtx (RecField r _) = not (isRecFieldRef r)
recFieldDeclCtx _ = False

tyDeclCtx :: ContextInfo -> Bool
tyDeclCtx TyDecl = True
tyDeclCtx _ = False

classDeclCtx :: ContextInfo -> Bool
classDeclCtx (Decl ClassDec _) = True
classDeclCtx _ = False

classTyDeclCtx :: ContextInfo -> Bool
classTyDeclCtx (ClassTyDecl _) = True
classTyDeclCtx _ = False

instBindCtx :: ContextInfo -> Bool
instBindCtx (ValBind InstanceBind _ _) = True
instBindCtx _ = False

isTypeSig, isDataDecl, isConstrDecl, isClassDecl,
  isMethodDecl, isInstanceBind, isInstDecl :: NodeInfo a -> Bool

isTypeSig = any (== typeSigAnnot) . nodeAnnotations
isDataDecl = any (== dataDeclAnnot) . nodeAnnotations
isConstrDecl = any (`elem` [constrAnnot, constrGadtAnnot]) . nodeAnnotations
isClassDecl = any (== classDeclAnnot) . nodeAnnotations
isMethodDecl = any (== classOpSigAnnot) . nodeAnnotations
isInstDecl = any (== instDeclAnnot) . nodeAnnotations
isInstanceBind =
  any (`elem` [varBindAnnot, patBindAnnot, funBindAnnot]) . nodeAnnotations

typeSigAnnot :: NodeAnnotation
typeSigAnnot = NodeAnnotation "TypeSig" "Sig"

dataDeclAnnot :: NodeAnnotation
dataDeclAnnot = NodeAnnotation "DataDecl" "TyClDecl"

constrAnnot :: NodeAnnotation
constrAnnot = NodeAnnotation "ConDeclH98" "ConDecl"

constrGadtAnnot :: NodeAnnotation
constrGadtAnnot = NodeAnnotation "ConDeclGADT" "ConDecl"

classOpSigAnnot :: NodeAnnotation
classOpSigAnnot = NodeAnnotation "ClassOpSig" "Sig"

classDeclAnnot :: NodeAnnotation
classDeclAnnot = NodeAnnotation "ClassDecl" "TyClDecl"

funBindAnnot :: NodeAnnotation
funBindAnnot = NodeAnnotation "FunBind" "HsBindLR"

patBindAnnot :: NodeAnnotation
patBindAnnot = NodeAnnotation "PatBind" "HsBindLR"

varBindAnnot :: NodeAnnotation
varBindAnnot = NodeAnnotation "VarBind" "HsBindLR"

instDeclAnnot :: NodeAnnotation
instDeclAnnot = NodeAnnotation "ClsInstD" "InstDecl"