{-# 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 []
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)
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
,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
,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
]