{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
module HieDb.Utils where

import qualified Data.Tree

import Prelude hiding (mod)

import Compat.HieBin
import Compat.HieTypes
import qualified Compat.HieTypes as HieTypes
import Compat.HieUtils
import Name
import Module
import NameCache
import UniqSupply
import SrcLoc
import DynFlags
import SysTools

import qualified Data.Map as M

import qualified FastString as FS

import System.Directory
import System.FilePath

import Control.Arrow ( (&&&) )
import Data.Bifunctor ( bimap )
import Data.List (find)
import Control.Monad.IO.Class
import qualified Data.Array as A

import Data.Char
import Data.Int
import Data.Maybe
import Data.Monoid
import Data.IORef

import HieDb.Types
import Database.SQLite.Simple

addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO ()
addTypeRef :: HieDb
-> FilePath
-> Array TypeIndex HieTypeFlat
-> Array TypeIndex (Maybe Int64)
-> RealSrcSpan
-> TypeIndex
-> IO ()
addTypeRef (HieDb -> Connection
getConn -> Connection
conn) FilePath
hf Array TypeIndex HieTypeFlat
arr Array TypeIndex (Maybe Int64)
ixs RealSrcSpan
sp = TypeIndex -> TypeIndex -> IO ()
go TypeIndex
0
  where
    sl :: TypeIndex
sl = RealSrcSpan -> TypeIndex
srcSpanStartLine RealSrcSpan
sp
    sc :: TypeIndex
sc = RealSrcSpan -> TypeIndex
srcSpanStartCol RealSrcSpan
sp
    el :: TypeIndex
el = RealSrcSpan -> TypeIndex
srcSpanEndLine RealSrcSpan
sp
    ec :: TypeIndex
ec = RealSrcSpan -> TypeIndex
srcSpanEndCol RealSrcSpan
sp
    go :: TypeIndex -> Int -> IO ()
    go :: TypeIndex -> TypeIndex -> IO ()
go TypeIndex
d TypeIndex
i = do
      case Array TypeIndex (Maybe Int64)
ixs Array TypeIndex (Maybe Int64) -> TypeIndex -> Maybe Int64
forall i e. Ix i => Array i e -> i -> e
A.! TypeIndex
i of
        Maybe Int64
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Int64
occ -> do
          let ref :: TypeRef
ref = Int64
-> FilePath
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeRef
TypeRef Int64
occ FilePath
hf TypeIndex
d TypeIndex
sl TypeIndex
sc TypeIndex
el TypeIndex
ec
          Connection -> Query -> TypeRef -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" TypeRef
ref
      let next :: TypeIndex -> IO ()
next = TypeIndex -> TypeIndex -> IO ()
go (TypeIndex
dTypeIndex -> TypeIndex -> TypeIndex
forall a. Num a => a -> a -> a
+TypeIndex
1)
      case Array TypeIndex HieTypeFlat
arr Array TypeIndex HieTypeFlat -> TypeIndex -> HieTypeFlat
forall i e. Ix i => Array i e -> i -> e
A.! TypeIndex
i of
        HTyVarTy Name
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if __GLASGOW_HASKELL__ >= 808
        HAppTy TypeIndex
x (HieArgs [(Bool, TypeIndex)]
xs) -> (TypeIndex -> IO ()) -> [TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeIndex -> IO ()
next (TypeIndex
xTypeIndex -> [TypeIndex] -> [TypeIndex]
forall a. a -> [a] -> [a]
:((Bool, TypeIndex) -> TypeIndex)
-> [(Bool, TypeIndex)] -> [TypeIndex]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, TypeIndex) -> TypeIndex
forall a b. (a, b) -> b
snd [(Bool, TypeIndex)]
xs)
#else
        HAppTy x y -> mapM_ next [x,y]
#endif
        HTyConApp IfaceTyCon
_ (HieArgs [(Bool, TypeIndex)]
xs) -> ((Bool, TypeIndex) -> IO ()) -> [(Bool, TypeIndex)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TypeIndex -> IO ()
next (TypeIndex -> IO ())
-> ((Bool, TypeIndex) -> TypeIndex) -> (Bool, TypeIndex) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, TypeIndex) -> TypeIndex
forall a b. (a, b) -> b
snd) [(Bool, TypeIndex)]
xs
        HForAllTy ((Name
_ , TypeIndex
a),ArgFlag
_) TypeIndex
b -> (TypeIndex -> IO ()) -> [TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeIndex -> IO ()
next [TypeIndex
a,TypeIndex
b]
        HFunTy TypeIndex
a TypeIndex
b -> (TypeIndex -> IO ()) -> [TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeIndex -> IO ()
next [TypeIndex
a,TypeIndex
b]
        HQualTy TypeIndex
a TypeIndex
b -> (TypeIndex -> IO ()) -> [TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeIndex -> IO ()
next [TypeIndex
a,TypeIndex
b]
        HLitTy IfaceTyLit
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        HCastTy TypeIndex
a -> TypeIndex -> TypeIndex -> IO ()
go TypeIndex
d TypeIndex
a
        HieTypeFlat
HCoercionTy -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

makeNc :: IO NameCache
makeNc :: IO NameCache
makeNc = do
  UniqSupply
uniq_supply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'z'
  NameCache -> IO NameCache
forall (m :: * -> *) a. Monad m => a -> m a
return (NameCache -> IO NameCache) -> NameCache -> IO NameCache
forall a b. (a -> b) -> a -> b
$ UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
uniq_supply []

-- | Recursively search for @.hie@ and @.hie-boot@  files in given directory
getHieFilesIn :: FilePath -> IO [FilePath]
getHieFilesIn :: FilePath -> IO [FilePath]
getHieFilesIn FilePath
path = do
  Bool
isFile <- FilePath -> IO Bool
doesFileExist FilePath
path
  if Bool
isFile Bool -> Bool -> Bool
&& (FilePath
"hie" FilePath -> FilePath -> Bool
`isExtensionOf` FilePath
path Bool -> Bool -> Bool
|| FilePath
"hie-boot" FilePath -> FilePath -> Bool
`isExtensionOf` FilePath
path) then do
      FilePath
path' <- FilePath -> IO FilePath
canonicalizePath FilePath
path
      [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path']
  else do
    Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
    if Bool
isDir then do
      [FilePath]
cnts <- FilePath -> IO [FilePath]
listDirectory FilePath
path
      FilePath -> IO [FilePath] -> IO [FilePath]
forall a. FilePath -> IO a -> IO a
withCurrentDirectory FilePath
path (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap FilePath -> IO [FilePath]
getHieFilesIn [FilePath]
cnts
    else
      [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

withHieFile :: (NameCacheMonad m, MonadIO m)
            => FilePath
            -> (HieFile -> m a)
            -> m a
withHieFile :: FilePath -> (HieFile -> m a) -> m a
withHieFile FilePath
path HieFile -> m a
act = do
  NameCacheUpdater
ncu <- m NameCacheUpdater
forall (m :: * -> *). NameCacheMonad m => m NameCacheUpdater
getNcUpdater
  HieFileResult
hiefile <- IO HieFileResult -> m HieFileResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HieFileResult -> m HieFileResult)
-> IO HieFileResult -> m HieFileResult
forall a b. (a -> b) -> a -> b
$ NameCacheUpdater -> FilePath -> IO HieFileResult
readHieFile NameCacheUpdater
ncu FilePath
path
  HieFile -> m a
act (HieFileResult -> HieFile
hie_file_result HieFileResult
hiefile)

-- | Given the path to a HieFile, it tries to find the SrcSpan of an External name in
-- it by loading it and then looking for the name in NameCache
findDefInFile :: OccName -> Module -> FilePath -> IO (Either HieDbErr (RealSrcSpan,Module))
findDefInFile :: OccName
-> Module -> FilePath -> IO (Either HieDbErr (RealSrcSpan, Module))
findDefInFile OccName
occ Module
mdl FilePath
file = do
  IORef NameCache
ncr <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (NameCache -> IO (IORef NameCache))
-> IO NameCache -> IO (IORef NameCache)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NameCache
makeNc
  ()
_ <- IORef NameCache -> DbMonad () -> IO ()
forall a. IORef NameCache -> DbMonad a -> IO a
runDbM IORef NameCache
ncr (DbMonad () -> IO ()) -> DbMonad () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (HieFile -> DbMonad ()) -> DbMonad ()
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
FilePath -> (HieFile -> m a) -> m a
withHieFile FilePath
file (DbMonad () -> HieFile -> DbMonad ()
forall a b. a -> b -> a
const (DbMonad () -> HieFile -> DbMonad ())
-> DbMonad () -> HieFile -> DbMonad ()
forall a b. (a -> b) -> a -> b
$ () -> DbMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  NameCache
nc <- IORef NameCache -> IO NameCache
forall a. IORef a -> IO a
readIORef IORef NameCache
ncr
  Either HieDbErr (RealSrcSpan, Module)
-> IO (Either HieDbErr (RealSrcSpan, Module))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr (RealSrcSpan, Module)
 -> IO (Either HieDbErr (RealSrcSpan, Module)))
-> Either HieDbErr (RealSrcSpan, Module)
-> IO (Either HieDbErr (RealSrcSpan, Module))
forall a b. (a -> b) -> a -> b
$ case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache (NameCache -> OrigNameCache
nsNames NameCache
nc) Module
mdl OccName
occ of
    Just Name
name -> case Name -> SrcSpan
nameSrcSpan Name
name of
      RealSrcSpan RealSrcSpan
sp -> (RealSrcSpan, Module) -> Either HieDbErr (RealSrcSpan, Module)
forall a b. b -> Either a b
Right (RealSrcSpan
sp, Module
mdl)
      UnhelpfulSpan FastString
msg -> HieDbErr -> Either HieDbErr (RealSrcSpan, Module)
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr (RealSrcSpan, Module))
-> HieDbErr -> Either HieDbErr (RealSrcSpan, Module)
forall a b. (a -> b) -> a -> b
$ Name -> FilePath -> HieDbErr
NameUnhelpfulSpan Name
name (FastString -> FilePath
FS.unpackFS FastString
msg)
    Maybe Name
Nothing -> HieDbErr -> Either HieDbErr (RealSrcSpan, Module)
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr (RealSrcSpan, Module))
-> HieDbErr -> Either HieDbErr (RealSrcSpan, Module)
forall a b. (a -> b) -> a -> b
$ OccName -> Maybe ModuleName -> Maybe UnitId -> HieDbErr
NameNotFound OccName
occ (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
mdl) (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
mdl)

pointCommand :: HieFile -> (Int, Int) -> Maybe (Int, Int) -> (HieAST TypeIndex -> a) -> [a]
pointCommand :: HieFile
-> (TypeIndex, TypeIndex)
-> Maybe (TypeIndex, TypeIndex)
-> (HieAST TypeIndex -> a)
-> [a]
pointCommand HieFile
hf (TypeIndex
sl,TypeIndex
sc) Maybe (TypeIndex, TypeIndex)
mep HieAST TypeIndex -> a
k =
    Map FastString a -> [a]
forall k a. Map k a -> [a]
M.elems (Map FastString a -> [a]) -> Map FastString a -> [a]
forall a b. (a -> b) -> a -> b
$ ((FastString -> HieAST TypeIndex -> Maybe a)
 -> Map FastString (HieAST TypeIndex) -> Map FastString a)
-> Map FastString (HieAST TypeIndex)
-> (FastString -> HieAST TypeIndex -> Maybe a)
-> Map FastString a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FastString -> HieAST TypeIndex -> Maybe a)
-> Map FastString (HieAST TypeIndex) -> Map FastString a
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (HieASTs TypeIndex -> Map FastString (HieAST TypeIndex)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts (HieASTs TypeIndex -> Map FastString (HieAST TypeIndex))
-> HieASTs TypeIndex -> Map FastString (HieAST TypeIndex)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs TypeIndex
hie_asts HieFile
hf) ((FastString -> HieAST TypeIndex -> Maybe a) -> Map FastString a)
-> (FastString -> HieAST TypeIndex -> Maybe a) -> Map FastString a
forall a b. (a -> b) -> a -> b
$ \FastString
fs HieAST TypeIndex
ast ->
      HieAST TypeIndex -> a
k (HieAST TypeIndex -> a) -> Maybe (HieAST TypeIndex) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealSrcSpan -> HieAST TypeIndex -> Maybe (HieAST TypeIndex)
forall a. RealSrcSpan -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining (FastString -> RealSrcSpan
sp FastString
fs) HieAST TypeIndex
ast
 where
   sloc :: FastString -> RealSrcLoc
sloc FastString
fs = FastString -> TypeIndex -> TypeIndex -> RealSrcLoc
mkRealSrcLoc FastString
fs TypeIndex
sl TypeIndex
sc
   eloc :: FastString -> RealSrcLoc
eloc FastString
fs = case Maybe (TypeIndex, TypeIndex)
mep of
     Maybe (TypeIndex, TypeIndex)
Nothing -> FastString -> RealSrcLoc
sloc FastString
fs
     Just (TypeIndex
el,TypeIndex
ec) -> FastString -> TypeIndex -> TypeIndex -> RealSrcLoc
mkRealSrcLoc FastString
fs TypeIndex
el TypeIndex
ec
   sp :: FastString -> RealSrcSpan
sp FastString
fs = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (FastString -> RealSrcLoc
sloc FastString
fs) (FastString -> RealSrcLoc
eloc FastString
fs)

dynFlagsForPrinting :: LibDir -> IO DynFlags
dynFlagsForPrinting :: LibDir -> IO DynFlags
dynFlagsForPrinting (LibDir FilePath
libdir) = do
  Settings
systemSettings <- FilePath -> IO Settings
initSysTools
#if __GLASGOW_HASKELL__ >= 808
                    FilePath
libdir
#else
                    (Just libdir)
#endif
#if __GLASGOW_HASKELL__ >= 810
  DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
systemSettings (LlvmConfig -> DynFlags) -> LlvmConfig -> DynFlags
forall a b. (a -> b) -> a -> b
$ [(FilePath, LlvmTarget)] -> [(TypeIndex, FilePath)] -> LlvmConfig
LlvmConfig [] []
#else
  return $ defaultDynFlags systemSettings ([], [])
#endif

isCons :: String -> Bool
isCons :: FilePath -> Bool
isCons (Char
':':FilePath
_) = Bool
True
isCons (Char
x:FilePath
_) | Char -> Bool
isUpper Char
x = Bool
True
isCons FilePath
_ = Bool
False

genRefsAndDecls :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> ([RefRow],[DeclRow])
genRefsAndDecls :: FilePath
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> ([RefRow], [DeclRow])
genRefsAndDecls FilePath
path Module
smdl Map Identifier [(RealSrcSpan, IdentifierDetails a)]
refmap = [(Identifier, (RealSrcSpan, IdentifierDetails a))]
-> ([RefRow], [DeclRow])
forall a a.
[(Either a Name, (RealSrcSpan, IdentifierDetails a))]
-> ([RefRow], [DeclRow])
genRows ([(Identifier, (RealSrcSpan, IdentifierDetails a))]
 -> ([RefRow], [DeclRow]))
-> [(Identifier, (RealSrcSpan, IdentifierDetails a))]
-> ([RefRow], [DeclRow])
forall a b. (a -> b) -> a -> b
$ [(Identifier, [(RealSrcSpan, IdentifierDetails a)])]
-> [(Identifier, (RealSrcSpan, IdentifierDetails a))]
forall t t. [(t, [t])] -> [(t, t)]
flat ([(Identifier, [(RealSrcSpan, IdentifierDetails a)])]
 -> [(Identifier, (RealSrcSpan, IdentifierDetails a))])
-> [(Identifier, [(RealSrcSpan, IdentifierDetails a)])]
-> [(Identifier, (RealSrcSpan, IdentifierDetails a))]
forall a b. (a -> b) -> a -> b
$ Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> [(Identifier, [(RealSrcSpan, IdentifierDetails a)])]
forall k a. Map k a -> [(k, a)]
M.toList Map Identifier [(RealSrcSpan, IdentifierDetails a)]
refmap
  where
    flat :: [(t, [t])] -> [(t, t)]
flat = ((t, [t]) -> [(t, t)]) -> [(t, [t])] -> [(t, t)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(t
a,[t]
xs) -> (t -> (t, t)) -> [t] -> [(t, t)]
forall a b. (a -> b) -> [a] -> [b]
map (t
a,) [t]
xs)
    genRows :: [(Either a Name, (RealSrcSpan, IdentifierDetails a))]
-> ([RefRow], [DeclRow])
genRows = ((Either a Name, (RealSrcSpan, IdentifierDetails a))
 -> ([RefRow], [DeclRow]))
-> [(Either a Name, (RealSrcSpan, IdentifierDetails a))]
-> ([RefRow], [DeclRow])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Either a Name, (RealSrcSpan, IdentifierDetails a))
-> ([RefRow], [DeclRow])
forall a a.
(Either a Name, (RealSrcSpan, IdentifierDetails a))
-> ([RefRow], [DeclRow])
go
    go :: (Either a Name, (RealSrcSpan, IdentifierDetails a))
-> ([RefRow], [DeclRow])
go = (Maybe RefRow -> [RefRow])
-> (Maybe DeclRow -> [DeclRow])
-> (Maybe RefRow, Maybe DeclRow)
-> ([RefRow], [DeclRow])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Maybe RefRow -> [RefRow]
forall a. Maybe a -> [a]
maybeToList Maybe DeclRow -> [DeclRow]
forall a. Maybe a -> [a]
maybeToList ((Maybe RefRow, Maybe DeclRow) -> ([RefRow], [DeclRow]))
-> ((Either a Name, (RealSrcSpan, IdentifierDetails a))
    -> (Maybe RefRow, Maybe DeclRow))
-> (Either a Name, (RealSrcSpan, IdentifierDetails a))
-> ([RefRow], [DeclRow])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either a Name, (RealSrcSpan, IdentifierDetails a)) -> Maybe RefRow
forall a b. (Either a Name, (RealSrcSpan, b)) -> Maybe RefRow
goRef ((Either a Name, (RealSrcSpan, IdentifierDetails a))
 -> Maybe RefRow)
-> ((Either a Name, (RealSrcSpan, IdentifierDetails a))
    -> Maybe DeclRow)
-> (Either a Name, (RealSrcSpan, IdentifierDetails a))
-> (Maybe RefRow, Maybe DeclRow)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Either a Name, (RealSrcSpan, IdentifierDetails a))
-> Maybe DeclRow
forall a a a.
(Either a Name, (a, IdentifierDetails a)) -> Maybe DeclRow
goDec)

    goRef :: (Either a Name, (RealSrcSpan, b)) -> Maybe RefRow
goRef (Right Name
name, (RealSrcSpan
sp,b
_))
      | Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name = RefRow -> Maybe RefRow
forall a. a -> Maybe a
Just (RefRow -> Maybe RefRow) -> RefRow -> Maybe RefRow
forall a b. (a -> b) -> a -> b
$
          FilePath
-> OccName
-> ModuleName
-> UnitId
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> RefRow
RefRow FilePath
path OccName
occ (Module -> ModuleName
moduleName Module
mod) (Module -> UnitId
moduleUnitId Module
mod) TypeIndex
sl TypeIndex
sc TypeIndex
el TypeIndex
ec
          where
            occ :: OccName
occ = Name -> OccName
nameOccName Name
name
            sl :: TypeIndex
sl = RealSrcSpan -> TypeIndex
srcSpanStartLine RealSrcSpan
sp
            sc :: TypeIndex
sc = RealSrcSpan -> TypeIndex
srcSpanStartCol RealSrcSpan
sp
            el :: TypeIndex
el = RealSrcSpan -> TypeIndex
srcSpanEndLine RealSrcSpan
sp
            ec :: TypeIndex
ec = RealSrcSpan -> TypeIndex
srcSpanEndCol RealSrcSpan
sp
    goRef (Either a Name, (RealSrcSpan, b))
_ = Maybe RefRow
forall a. Maybe a
Nothing

    goDec :: (Either a Name, (a, IdentifierDetails a)) -> Maybe DeclRow
goDec (Right Name
name,(a
_,IdentifierDetails a
dets))
      | Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
      , Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
smdl
      , OccName
occ  <- Name -> OccName
nameOccName Name
name
      , Set ContextInfo
info <- IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets
      , Just RealSrcSpan
sp <- Set ContextInfo -> Maybe RealSrcSpan
getBindSpan Set ContextInfo
info
      , Bool
is_root <- Set ContextInfo -> Bool
isRoot Set ContextInfo
info
      , TypeIndex
sl   <- RealSrcSpan -> TypeIndex
srcSpanStartLine RealSrcSpan
sp
      , TypeIndex
sc   <- RealSrcSpan -> TypeIndex
srcSpanStartCol RealSrcSpan
sp
      , TypeIndex
el   <- RealSrcSpan -> TypeIndex
srcSpanEndLine RealSrcSpan
sp
      , TypeIndex
ec   <- RealSrcSpan -> TypeIndex
srcSpanEndCol RealSrcSpan
sp
      = DeclRow -> Maybe DeclRow
forall a. a -> Maybe a
Just (DeclRow -> Maybe DeclRow) -> DeclRow -> Maybe DeclRow
forall a b. (a -> b) -> a -> b
$ FilePath
-> OccName
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> Bool
-> DeclRow
DeclRow FilePath
path OccName
occ TypeIndex
sl TypeIndex
sc TypeIndex
el TypeIndex
ec Bool
is_root
    goDec (Either a Name, (a, IdentifierDetails a))
_ = Maybe DeclRow
forall a. Maybe a
Nothing

    isRoot :: Set ContextInfo -> Bool
isRoot = (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case
      ValBind BindType
InstanceBind Scope
_ Maybe RealSrcSpan
_ -> Bool
True
      Decl DeclType
_ Maybe RealSrcSpan
_ -> Bool
True
      ContextInfo
_ -> Bool
False)

    getBindSpan :: Set ContextInfo -> Maybe RealSrcSpan
getBindSpan = First RealSrcSpan -> Maybe RealSrcSpan
forall a. First a -> Maybe a
getFirst (First RealSrcSpan -> Maybe RealSrcSpan)
-> (Set ContextInfo -> First RealSrcSpan)
-> Set ContextInfo
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContextInfo -> First RealSrcSpan)
-> Set ContextInfo -> First RealSrcSpan
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe RealSrcSpan -> First RealSrcSpan
forall a. Maybe a -> First a
First (Maybe RealSrcSpan -> First RealSrcSpan)
-> (ContextInfo -> Maybe RealSrcSpan)
-> ContextInfo
-> First RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Maybe RealSrcSpan
goDecl)
    goDecl :: ContextInfo -> Maybe RealSrcSpan
goDecl (ValBind BindType
_ Scope
_ Maybe RealSrcSpan
sp) = Maybe RealSrcSpan
sp
    goDecl (PatternBind Scope
_ Scope
_ Maybe RealSrcSpan
sp) = Maybe RealSrcSpan
sp
    goDecl (Decl DeclType
_ Maybe RealSrcSpan
sp) = Maybe RealSrcSpan
sp
    goDecl (RecField RecFieldContext
_ Maybe RealSrcSpan
sp) = Maybe RealSrcSpan
sp
    goDecl ContextInfo
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing

genDefRow :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> [DefRow]
genDefRow :: FilePath
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> [DefRow]
genDefRow FilePath
path Module
smod Map Identifier [(RealSrcSpan, IdentifierDetails a)]
refmap = [(Identifier, [(RealSrcSpan, IdentifierDetails a)])] -> [DefRow]
forall a a.
[(Either a Name, [(RealSrcSpan, IdentifierDetails a)])] -> [DefRow]
genRows ([(Identifier, [(RealSrcSpan, IdentifierDetails a)])] -> [DefRow])
-> [(Identifier, [(RealSrcSpan, IdentifierDetails a)])] -> [DefRow]
forall a b. (a -> b) -> a -> b
$ Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> [(Identifier, [(RealSrcSpan, IdentifierDetails a)])]
forall k a. Map k a -> [(k, a)]
M.toList Map Identifier [(RealSrcSpan, IdentifierDetails a)]
refmap
  where
    genRows :: [(Either a Name, [(RealSrcSpan, IdentifierDetails a)])] -> [DefRow]
genRows = ((Either a Name, [(RealSrcSpan, IdentifierDetails a)])
 -> Maybe DefRow)
-> [(Either a Name, [(RealSrcSpan, IdentifierDetails a)])]
-> [DefRow]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Either a Name, [(RealSrcSpan, IdentifierDetails a)])
-> Maybe DefRow
forall (t :: * -> *) a a.
Foldable t =>
(Either a Name, t (RealSrcSpan, IdentifierDetails a))
-> Maybe DefRow
go
    getSpan :: Name -> t (RealSrcSpan, IdentifierDetails a) -> Maybe RealSrcSpan
getSpan Name
name t (RealSrcSpan, IdentifierDetails a)
dets
      | RealSrcSpan RealSrcSpan
sp <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
      | Bool
otherwise = do
          (RealSrcSpan
sp, IdentifierDetails a
_dets) <- ((RealSrcSpan, IdentifierDetails a) -> Bool)
-> t (RealSrcSpan, IdentifierDetails a)
-> Maybe (RealSrcSpan, IdentifierDetails a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (RealSrcSpan, IdentifierDetails a) -> Bool
forall a a. (a, IdentifierDetails a) -> Bool
defSpan t (RealSrcSpan, IdentifierDetails a)
dets
          RealSrcSpan -> Maybe RealSrcSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
sp

    defSpan :: (a, IdentifierDetails a) -> Bool
defSpan = (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isDef (Set ContextInfo -> Bool)
-> ((a, IdentifierDetails a) -> Set ContextInfo)
-> (a, IdentifierDetails a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo (IdentifierDetails a -> Set ContextInfo)
-> ((a, IdentifierDetails a) -> IdentifierDetails a)
-> (a, IdentifierDetails a)
-> Set ContextInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, IdentifierDetails a) -> IdentifierDetails a
forall a b. (a, b) -> b
snd
    isDef :: ContextInfo -> Bool
isDef (ValBind BindType
RegularBind Scope
_ Maybe RealSrcSpan
_) = Bool
True
    isDef PatternBind{}             = Bool
True
    isDef Decl{}                    = Bool
True
    isDef ContextInfo
_                         = Bool
False

    go :: (Either a Name, t (RealSrcSpan, IdentifierDetails a))
-> Maybe DefRow
go (Right Name
name,t (RealSrcSpan, IdentifierDetails a)
dets)
      | Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
      , Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
smod
      , OccName
occ  <- Name -> OccName
nameOccName Name
name
      , Just RealSrcSpan
sp <- Name -> t (RealSrcSpan, IdentifierDetails a) -> Maybe RealSrcSpan
forall (t :: * -> *) a.
Foldable t =>
Name -> t (RealSrcSpan, IdentifierDetails a) -> Maybe RealSrcSpan
getSpan Name
name t (RealSrcSpan, IdentifierDetails a)
dets
      , TypeIndex
sl   <- RealSrcSpan -> TypeIndex
srcSpanStartLine RealSrcSpan
sp
      , TypeIndex
sc   <- RealSrcSpan -> TypeIndex
srcSpanStartCol RealSrcSpan
sp
      , TypeIndex
el   <- RealSrcSpan -> TypeIndex
srcSpanEndLine RealSrcSpan
sp
      , TypeIndex
ec   <- RealSrcSpan -> TypeIndex
srcSpanEndCol RealSrcSpan
sp
      = DefRow -> Maybe DefRow
forall a. a -> Maybe a
Just (DefRow -> Maybe DefRow) -> DefRow -> Maybe DefRow
forall a b. (a -> b) -> a -> b
$ FilePath
-> OccName
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> DefRow
DefRow FilePath
path OccName
occ TypeIndex
sl TypeIndex
sc TypeIndex
el TypeIndex
ec
    go (Either a Name, t (RealSrcSpan, IdentifierDetails a))
_ = Maybe DefRow
forall a. Maybe a
Nothing

identifierTree :: HieTypes.HieAST a -> Data.Tree.Tree ( HieTypes.HieAST a )
identifierTree :: HieAST a -> Tree (HieAST a)
identifierTree HieTypes.Node{ NodeInfo a
nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeInfo :: NodeInfo a
nodeInfo, RealSrcSpan
nodeSpan :: forall a. HieAST a -> RealSrcSpan
nodeSpan :: RealSrcSpan
nodeSpan, [HieAST a]
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren :: [HieAST a]
nodeChildren } =
  Node :: forall a. a -> Forest a -> Tree a
Data.Tree.Node
    { rootLabel :: HieAST a
rootLabel = Node :: forall a. NodeInfo a -> RealSrcSpan -> [HieAST a] -> HieAST a
HieTypes.Node{ NodeInfo a
nodeInfo :: NodeInfo a
nodeInfo :: NodeInfo a
nodeInfo, RealSrcSpan
nodeSpan :: RealSrcSpan
nodeSpan :: RealSrcSpan
nodeSpan, nodeChildren :: [HieAST a]
nodeChildren = [HieAST a]
forall a. Monoid a => a
mempty }
    , subForest :: Forest (HieAST a)
subForest = (HieAST a -> Tree (HieAST a)) -> [HieAST a] -> Forest (HieAST a)
forall a b. (a -> b) -> [a] -> [b]
map HieAST a -> Tree (HieAST a)
forall a. HieAST a -> Tree (HieAST a)
identifierTree [HieAST a]
nodeChildren
    }