{-# 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 qualified Data.Map as M


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 HieDb.Compat
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]
#if __GLASGOW_HASKELL__ >= 900
        HFunTy a b c -> mapM_ next [a,b,c]
#else
        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]
#endif
        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
#if __GLASGOW_HASKELL__ >= 900
      RealSrcSpan sp _ -> Right (sp, mdl)
#else
      RealSrcSpan RealSrcSpan
sp -> (RealSrcSpan, Module) -> Either HieDbErr (RealSrcSpan, Module)
forall a b. b -> Either a b
Right (RealSrcSpan
sp, Module
mdl)
#endif
      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
unpackFS (FastString -> FilePath) -> FastString -> FilePath
forall a b. (a -> b) -> a -> b
$ FastString -> FastString
unhelpfulSpanFS 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 Unit -> 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) (Unit -> Maybe Unit
forall a. a -> Maybe a
Just (Unit -> Maybe Unit) -> Unit -> Maybe Unit
forall a b. (a -> b) -> a -> b
$ Module -> Unit
moduleUnit 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 -> RealSrcSpan) -> FastString -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> FastString
hiePathToFS 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
-> Unit
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> TypeIndex
-> RefRow
RefRow FilePath
path OccName
occ (Module -> ModuleName
moduleName Module
mod) (Module -> Unit
moduleUnit 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
#if __GLASGOW_HASKELL__ >= 900
      | RealSrcSpan sp _ <- nameSrcSpan name = Just sp
#else
      | RealSrcSpan RealSrcSpan
sp <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
#endif
      | 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 nd :: HieAST a
nd@HieTypes.Node{ [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 = HieAST a
nd { 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
    }

generateExports :: FilePath -> [AvailInfo] -> [ExportRow]
generateExports :: FilePath -> [AvailInfo] -> [ExportRow]
generateExports FilePath
fp = (AvailInfo -> [ExportRow]) -> [AvailInfo] -> [ExportRow]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [ExportRow]
generateExport where
  generateExport :: AvailInfo -> [ExportRow]
  generateExport :: AvailInfo -> [ExportRow]
generateExport (AvailName Name
n)
    = [ExportRow :: FilePath
-> OccName
-> ModuleName
-> Unit
-> Maybe OccName
-> Maybe ModuleName
-> Maybe Unit
-> Bool
-> ExportRow
ExportRow
        { exportHieFile :: FilePath
exportHieFile = FilePath
fp
        , exportName :: OccName
exportName = Name -> OccName
nameOccName Name
n
        , exportMod :: ModuleName
exportMod = Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
        , exportUnit :: Unit
exportUnit = Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
        , exportParent :: Maybe OccName
exportParent = Maybe OccName
forall a. Maybe a
Nothing
        , exportParentMod :: Maybe ModuleName
exportParentMod = Maybe ModuleName
forall a. Maybe a
Nothing
        , exportParentUnit :: Maybe Unit
exportParentUnit = Maybe Unit
forall a. Maybe a
Nothing
        , exportIsDatacon :: Bool
exportIsDatacon = Bool
False
        }]
  generateExport (AvailFL FieldLabel
fl)
    = [ExportRow :: FilePath
-> OccName
-> ModuleName
-> Unit
-> Maybe OccName
-> Maybe ModuleName
-> Maybe Unit
-> Bool
-> ExportRow
ExportRow
        { exportHieFile :: FilePath
exportHieFile = FilePath
fp
        , exportName :: OccName
exportName = OccName
n
        , exportMod :: ModuleName
exportMod = ModuleName
m
        , exportUnit :: Unit
exportUnit = Unit
u
        , exportParent :: Maybe OccName
exportParent = Maybe OccName
forall a. Maybe a
Nothing
        , exportParentMod :: Maybe ModuleName
exportParentMod = Maybe ModuleName
forall a. Maybe a
Nothing
        , exportParentUnit :: Maybe Unit
exportParentUnit = Maybe Unit
forall a. Maybe a
Nothing
        , exportIsDatacon :: Bool
exportIsDatacon = Bool
False
        }]
      where
        (OccName
n, ModuleName
m, Unit
u) = (FastString -> OccName
mkVarOccFS (FastString -> OccName) -> FastString -> OccName
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLabel
fl
                    -- For fields, the module details come from the parent
                    ,Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl
                    ,Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl
                    )
  generateExport (AvailTC Name
name [Name]
pieces [FieldLabel]
fields)
    = ExportRow :: FilePath
-> OccName
-> ModuleName
-> Unit
-> Maybe OccName
-> Maybe ModuleName
-> Maybe Unit
-> Bool
-> ExportRow
ExportRow
        { exportHieFile :: FilePath
exportHieFile = FilePath
fp
        , exportName :: OccName
exportName = Name -> OccName
nameOccName Name
name
        , exportMod :: ModuleName
exportMod = Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
        , exportUnit :: Unit
exportUnit = Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
        , exportParent :: Maybe OccName
exportParent = Maybe OccName
forall a. Maybe a
Nothing
        , exportParentMod :: Maybe ModuleName
exportParentMod = Maybe ModuleName
forall a. Maybe a
Nothing
        , exportParentUnit :: Maybe Unit
exportParentUnit = Maybe Unit
forall a. Maybe a
Nothing
        , exportIsDatacon :: Bool
exportIsDatacon = Bool
False}
    ExportRow -> [ExportRow] -> [ExportRow]
forall a. a -> [a] -> [a]
: [ExportRow :: FilePath
-> OccName
-> ModuleName
-> Unit
-> Maybe OccName
-> Maybe ModuleName
-> Maybe Unit
-> Bool
-> ExportRow
ExportRow
        { exportHieFile :: FilePath
exportHieFile = FilePath
fp
        , exportName :: OccName
exportName = OccName
n
        , exportMod :: ModuleName
exportMod = ModuleName
m
        , exportUnit :: Unit
exportUnit = Unit
u
        , exportParent :: Maybe OccName
exportParent = OccName -> Maybe OccName
forall a. a -> Maybe a
Just (Name -> OccName
nameOccName Name
name)
        , exportParentMod :: Maybe ModuleName
exportParentMod = ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
        , exportParentUnit :: Maybe Unit
exportParentUnit = Unit -> Maybe Unit
forall a. a -> Maybe a
Just (Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
        , exportIsDatacon :: Bool
exportIsDatacon = Bool
False}
      | (OccName
n,ModuleName
m,Unit
u) <- (Name -> (OccName, ModuleName, Unit))
-> [Name] -> [(OccName, ModuleName, Unit)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
n ->
                        (Name -> OccName
nameOccName Name
n
                        ,Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
                        ,Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
                        ))
                      (TypeIndex -> [Name] -> [Name]
forall a. TypeIndex -> [a] -> [a]
drop TypeIndex
1 [Name]
pieces)
               [(OccName, ModuleName, Unit)]
-> [(OccName, ModuleName, Unit)] -> [(OccName, ModuleName, Unit)]
forall a. Semigroup a => a -> a -> a
<> (FieldLabel -> (OccName, ModuleName, Unit))
-> [FieldLabel] -> [(OccName, ModuleName, Unit)]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldLabel
s ->
                        (FastString -> OccName
mkVarOccFS (FastString -> OccName) -> FastString -> OccName
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLabel
s
                        -- For fields, the module details come from the parent
                        ,Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
                        ,Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
                        ))
                      [FieldLabel]
fields
      ]