{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Calligraphy.Phases.Parse
( parseHieFiles,
ppParseError,
ppParsePhaseDebugInfo,
ParseError (..),
ParsePhaseDebugInfo (..),
)
where
import qualified Calligraphy.Compat.GHC as GHC
import Calligraphy.Compat.Lib (isDerivingNode, isInlineNode, isInstanceNode, isMinimalNode, isTypeSignatureNode, mergeSpans, sourceInfo)
import qualified Calligraphy.Compat.Lib as GHC
import Calligraphy.Util.LexTree (LexTree, TreeError (..), foldLexTree)
import qualified Calligraphy.Util.LexTree as LT
import Calligraphy.Util.Printer
import Calligraphy.Util.Types
import Control.Monad.Except
import Control.Monad.State
import Data.Array (Array)
import qualified Data.Array as Array
import Data.EnumMap (EnumMap)
import qualified Data.EnumMap as EnumMap
import Data.EnumSet (EnumSet)
import qualified Data.EnumSet as EnumSet
import qualified Data.Foldable as Foldable
import Data.List (unzip4)
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Map as Map
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree (Forest, Tree (..))
data RawDecl = RawDecl
{ RawDecl -> String
_rdName :: !String,
RawDecl -> EnumSet GHCKey
rdKeys :: !(EnumSet GHCKey),
RawDecl -> DeclType
_rdTyp :: !DeclType,
RawDecl -> Loc
rdStart :: !Loc,
RawDecl -> Loc
rdEnd :: !Loc
}
data ParseError = TreeError
{ ParseError -> String
_peModuleName :: String,
ParseError -> String
_peModulePath :: FilePath,
ParseError -> TreeError Loc RawDecl
_peError :: TreeError Loc RawDecl
}
ppParseError :: Prints ParseError
ppParseError :: Prints ParseError
ppParseError (TreeError String
str String
path TreeError Loc RawDecl
err) = do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Parse error in module " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints (TreeError Loc RawDecl)
ppTreeError TreeError Loc RawDecl
err
where
ppTreeError :: Prints (TreeError Loc RawDecl)
ppTreeError :: Prints (TreeError Loc RawDecl)
ppTreeError (InvalidBounds Loc
l RawDecl
decl Loc
r) = do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid bounds " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Loc, Loc) -> String
forall a. Show a => a -> String
show (Loc
l, Loc
r) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"while inserting"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints RawDecl
ppRawDecl RawDecl
decl
ppTreeError (OverlappingBounds RawDecl
a RawDecl
b Loc
l Loc
r) = do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Clashing bounds: (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Loc, Loc) -> String
forall a. Show a => a -> String
show (Loc
l, Loc
r) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Node 1:"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints RawDecl
ppRawDecl RawDecl
a
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Node 2:"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints RawDecl
ppRawDecl RawDecl
b
ppTreeError TreeError Loc RawDecl
MidSplit = String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"MidSplit"
ppTreeError (LexicalError Loc
l RawDecl
decl Loc
r LexTree Loc RawDecl
t) = do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Lexical error while inserting"
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Node:"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints RawDecl
ppRawDecl RawDecl
decl
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Bounds:"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ (Loc, Loc) -> Printer ()
forall (m :: * -> *) a. (MonadPrint m, Show a) => a -> m ()
showLn (Loc
l, Loc
r)
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Tree:"
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ do
Prints (LexTree Loc RawDecl)
ppLexTree LexTree Loc RawDecl
t
ppRawDecl :: Prints RawDecl
ppRawDecl :: Prints RawDecl
ppRawDecl (RawDecl String
name EnumSet GHCKey
keys DeclType
typ Loc
st Loc
end) = do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
name
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DeclType -> String
forall a. Show a => a -> String
show DeclType
typ
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Span: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Loc, Loc) -> String
forall a. Show a => a -> String
show (Loc
st, Loc
end)
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Keys: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (GHCKey -> String
forall a. Show a => a -> String
show (GHCKey -> String) -> [GHCKey] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
keys)
ppLexTree :: Prints (LexTree Loc RawDecl)
ppLexTree :: Prints (LexTree Loc RawDecl)
ppLexTree = Printer ()
-> (Printer ()
-> Loc -> RawDecl -> Printer () -> Loc -> Printer () -> Printer ())
-> Prints (LexTree Loc RawDecl)
forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree (() -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Printer ()
-> Loc -> RawDecl -> Printer () -> Loc -> Printer () -> Printer ())
-> Prints (LexTree Loc RawDecl))
-> (Printer ()
-> Loc -> RawDecl -> Printer () -> Loc -> Printer () -> Printer ())
-> Prints (LexTree Loc RawDecl)
forall a b. (a -> b) -> a -> b
$ \Printer ()
ls Loc
l RawDecl
decl Printer ()
m Loc
r Printer ()
rs -> do
Printer ()
ls
(Loc, Loc) -> Printer ()
forall (m :: * -> *) a. (MonadPrint m, Show a) => a -> m ()
showLn (Loc
l, Loc
r)
Prints RawDecl
ppRawDecl RawDecl
decl
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent Printer ()
m
Printer ()
rs
ghcNameKey :: GHC.Name -> GHCKey
ghcNameKey :: Name -> GHCKey
ghcNameKey = Int -> GHCKey
GHCKey (Int -> GHCKey) -> (Name -> Int) -> Name -> GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
GHC.getKey (Unique -> Int) -> (Name -> Unique) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Unique
GHC.nameUnique
newtype ParsePhaseDebugInfo = ParsePhaseDebugInfo {ParsePhaseDebugInfo -> [(String, LexTree Loc RawDecl)]
modulesLexTrees :: [(String, LexTree Loc RawDecl)]}
ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo
ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo
ppParsePhaseDebugInfo (ParsePhaseDebugInfo [(String, LexTree Loc RawDecl)]
mods) = [(String, LexTree Loc RawDecl)]
-> ((String, LexTree Loc RawDecl) -> Printer ()) -> Printer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, LexTree Loc RawDecl)]
mods (((String, LexTree Loc RawDecl) -> Printer ()) -> Printer ())
-> ((String, LexTree Loc RawDecl) -> Printer ()) -> Printer ()
forall a b. (a -> b) -> a -> b
$ \(String
modName, LexTree Loc RawDecl
ltree) -> do
String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
modName
Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Prints (LexTree Loc RawDecl)
ppLexTree LexTree Loc RawDecl
ltree
data ParsedFile = ParsedFile
{ ParsedFile -> String
_pfModuleName :: String,
ParsedFile -> String
_pfFilePath :: FilePath,
ParsedFile -> Forest Decl
_pfDecls :: Forest Decl,
ParsedFile -> Set (GHCKey, GHCKey)
_pfCalls :: Set (GHCKey, GHCKey),
ParsedFile -> EnumMap GHCKey (EnumSet GHCKey)
_pfTypings :: EnumMap GHCKey (EnumSet GHCKey),
ParsedFile -> LexTree Loc RawDecl
_pfDebugTree :: LexTree Loc RawDecl
}
type HieParse a = StateT (Key, EnumMap GHCKey Key) (Either ParseError) a
parseHieFiles ::
[GHC.HieFile] ->
Either ParseError (ParsePhaseDebugInfo, CallGraph)
parseHieFiles :: [HieFile] -> Either ParseError (ParsePhaseDebugInfo, CallGraph)
parseHieFiles [HieFile]
files = (\([ParsedFile]
parsed, (Key
_, EnumMap GHCKey Key
keymap)) -> [ParsedFile]
-> EnumMap GHCKey Key -> (ParsePhaseDebugInfo, CallGraph)
mkCallGraph [ParsedFile]
parsed EnumMap GHCKey Key
keymap) (([ParsedFile], (Key, EnumMap GHCKey Key))
-> (ParsePhaseDebugInfo, CallGraph))
-> Either ParseError ([ParsedFile], (Key, EnumMap GHCKey Key))
-> Either ParseError (ParsePhaseDebugInfo, CallGraph)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Key, EnumMap GHCKey Key) (Either ParseError) [ParsedFile]
-> (Key, EnumMap GHCKey Key)
-> Either ParseError ([ParsedFile], (Key, EnumMap GHCKey Key))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((HieFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile)
-> [HieFile]
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) [ParsedFile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HieFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile
parseHieFile [HieFile]
files) (Int -> Key
Key Int
0, EnumMap GHCKey Key
forall a. Monoid a => a
mempty)
where
mkCallGraph :: [ParsedFile] -> EnumMap GHCKey Key -> (ParsePhaseDebugInfo, CallGraph)
mkCallGraph :: [ParsedFile]
-> EnumMap GHCKey Key -> (ParsePhaseDebugInfo, CallGraph)
mkCallGraph [ParsedFile]
parsed EnumMap GHCKey Key
keymap =
let ([Module]
mods, [(String, LexTree Loc RawDecl)]
debugs, [Set (GHCKey, GHCKey)]
calls, [EnumMap GHCKey (EnumSet GHCKey)]
typings) = [(Module, (String, LexTree Loc RawDecl), Set (GHCKey, GHCKey),
EnumMap GHCKey (EnumSet GHCKey))]
-> ([Module], [(String, LexTree Loc RawDecl)],
[Set (GHCKey, GHCKey)], [EnumMap GHCKey (EnumSet GHCKey)])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ((ParsedFile
-> (Module, (String, LexTree Loc RawDecl), Set (GHCKey, GHCKey),
EnumMap GHCKey (EnumSet GHCKey)))
-> [ParsedFile]
-> [(Module, (String, LexTree Loc RawDecl), Set (GHCKey, GHCKey),
EnumMap GHCKey (EnumSet GHCKey))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ParsedFile String
name String
path Forest Decl
decls Set (GHCKey, GHCKey)
call EnumMap GHCKey (EnumSet GHCKey)
typing LexTree Loc RawDecl
ltree) -> (String -> String -> Forest Decl -> Module
Module String
name String
path Forest Decl
decls, (String
name, LexTree Loc RawDecl
ltree), Set (GHCKey, GHCKey)
call, EnumMap GHCKey (EnumSet GHCKey)
typing)) [ParsedFile]
parsed)
typeEdges :: Set (Key, Key)
typeEdges = EnumMap GHCKey Key -> Set (GHCKey, GHCKey) -> Set (Key, Key)
forall a b.
(Enum a, Ord b) =>
EnumMap a b -> Set (a, a) -> Set (b, b)
rekeyCalls EnumMap GHCKey Key
keymap (Set (GHCKey, GHCKey) -> Set (Key, Key))
-> ([(GHCKey, GHCKey)] -> Set (GHCKey, GHCKey))
-> [(GHCKey, GHCKey)]
-> Set (Key, Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(GHCKey, GHCKey)] -> Set (GHCKey, GHCKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(GHCKey, GHCKey)] -> Set (Key, Key))
-> [(GHCKey, GHCKey)] -> Set (Key, Key)
forall a b. (a -> b) -> a -> b
$ do
(GHCKey
term, EnumSet GHCKey
types) <- EnumMap GHCKey (EnumSet GHCKey) -> [(GHCKey, EnumSet GHCKey)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.toList ([EnumMap GHCKey (EnumSet GHCKey)]
-> EnumMap GHCKey (EnumSet GHCKey)
forall a. Monoid a => [a] -> a
mconcat [EnumMap GHCKey (EnumSet GHCKey)]
typings)
GHCKey
typ <- EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
types
(GHCKey, GHCKey) -> [(GHCKey, GHCKey)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCKey
term, GHCKey
typ)
in ([(String, LexTree Loc RawDecl)] -> ParsePhaseDebugInfo
ParsePhaseDebugInfo [(String, LexTree Loc RawDecl)]
debugs, [Module] -> Set (Key, Key) -> Set (Key, Key) -> CallGraph
CallGraph [Module]
mods (EnumMap GHCKey Key -> Set (GHCKey, GHCKey) -> Set (Key, Key)
forall a b.
(Enum a, Ord b) =>
EnumMap a b -> Set (a, a) -> Set (b, b)
rekeyCalls EnumMap GHCKey Key
keymap ([Set (GHCKey, GHCKey)] -> Set (GHCKey, GHCKey)
forall a. Monoid a => [a] -> a
mconcat [Set (GHCKey, GHCKey)]
calls)) Set (Key, Key)
typeEdges)
parseHieFile :: GHC.HieFile -> HieParse ParsedFile
parseHieFile :: HieFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile
parseHieFile file :: HieFile
file@(GHC.HieFile String
filepath Module
mdl Array Int HieTypeFlat
_ HieASTs Int
_ [AvailInfo]
avails ByteString
_) = do
LexTree Loc RawDecl
lextree <- (TreeError Loc RawDecl
-> StateT
(Key, EnumMap GHCKey Key)
(Either ParseError)
(LexTree Loc RawDecl))
-> (LexTree Loc RawDecl
-> StateT
(Key, EnumMap GHCKey Key)
(Either ParseError)
(LexTree Loc RawDecl))
-> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (LexTree Loc RawDecl)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ParseError
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (LexTree Loc RawDecl)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError
-> StateT
(Key, EnumMap GHCKey Key)
(Either ParseError)
(LexTree Loc RawDecl))
-> (TreeError Loc RawDecl -> ParseError)
-> TreeError Loc RawDecl
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (LexTree Loc RawDecl)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> TreeError Loc RawDecl -> ParseError
TreeError String
modname String
filepath) LexTree Loc RawDecl
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (LexTree Loc RawDecl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
-> StateT
(Key, EnumMap GHCKey Key)
(Either ParseError)
(LexTree Loc RawDecl))
-> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (LexTree Loc RawDecl)
forall a b. (a -> b) -> a -> b
$ [RawDecl] -> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
structure [RawDecl]
decls
let calls :: Set (GHCKey, GHCKey)
calls = LexTree Loc GHCKey -> Set (GHCKey, GHCKey)
resolveCalls ((RawDecl -> GHCKey) -> LexTree Loc RawDecl -> LexTree Loc GHCKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EnumSet GHCKey -> GHCKey
forall k. Enum k => EnumSet k -> k
EnumSet.findMin (EnumSet GHCKey -> GHCKey)
-> (RawDecl -> EnumSet GHCKey) -> RawDecl -> GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawDecl -> EnumSet GHCKey
rdKeys) LexTree Loc RawDecl
lextree)
Forest Decl
forest <- (RawDecl
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl)
-> Forest RawDecl
-> StateT
(Key, EnumMap GHCKey Key) (Either ParseError) (Forest Decl)
forall a b. Traversal (Forest a) (Forest b) a b
forestT (EnumSet GHCKey
-> RawDecl
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl
mkDecl EnumSet GHCKey
exportKeys) (LexTree Loc RawDecl -> Forest RawDecl
mkForest LexTree Loc RawDecl
lextree)
ParsedFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile)
-> ParsedFile
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ParsedFile
forall a b. (a -> b) -> a -> b
$ String
-> String
-> Forest Decl
-> Set (GHCKey, GHCKey)
-> EnumMap GHCKey (EnumSet GHCKey)
-> LexTree Loc RawDecl
-> ParsedFile
ParsedFile String
modname String
filepath Forest Decl
forest Set (GHCKey, GHCKey)
calls EnumMap GHCKey (EnumSet GHCKey)
types LexTree Loc RawDecl
lextree
where
modname :: String
modname = ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
GHC.moduleName Module
mdl)
exportKeys :: EnumSet GHCKey
exportKeys = [GHCKey] -> EnumSet GHCKey
forall k. Enum k => [k] -> EnumSet k
EnumSet.fromList ([GHCKey] -> EnumSet GHCKey) -> [GHCKey] -> EnumSet GHCKey
forall a b. (a -> b) -> a -> b
$ (Name -> GHCKey) -> [Name] -> [GHCKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> GHCKey
ghcNameKey ([Name] -> [GHCKey]) -> [Name] -> [GHCKey]
forall a b. (a -> b) -> a -> b
$ [AvailInfo]
avails [AvailInfo] -> (AvailInfo -> [Name]) -> [Name]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AvailInfo -> [Name]
GHC.availNames
Collect [RawDecl]
decls [(Loc, GHCKey)]
useSites EnumMap GHCKey (EnumSet GHCKey)
types = HieFile -> Collect
collect HieFile
file
resolveCalls :: LexTree Loc GHCKey -> Set (GHCKey, GHCKey)
resolveCalls :: LexTree Loc GHCKey -> Set (GHCKey, GHCKey)
resolveCalls LexTree Loc GHCKey
lextree = (((Loc, GHCKey) -> Set (GHCKey, GHCKey))
-> [(Loc, GHCKey)] -> Set (GHCKey, GHCKey))
-> [(Loc, GHCKey)]
-> ((Loc, GHCKey) -> Set (GHCKey, GHCKey))
-> Set (GHCKey, GHCKey)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Loc, GHCKey) -> Set (GHCKey, GHCKey))
-> [(Loc, GHCKey)] -> Set (GHCKey, GHCKey)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(Loc, GHCKey)]
useSites (((Loc, GHCKey) -> Set (GHCKey, GHCKey)) -> Set (GHCKey, GHCKey))
-> ((Loc, GHCKey) -> Set (GHCKey, GHCKey)) -> Set (GHCKey, GHCKey)
forall a b. (a -> b) -> a -> b
$ \(Loc
loc, GHCKey
callee) ->
case Loc -> LexTree Loc GHCKey -> Maybe GHCKey
forall p a. Ord p => p -> LexTree p a -> Maybe a
LT.lookup Loc
loc LexTree Loc GHCKey
lextree of
Maybe GHCKey
Nothing -> Set (GHCKey, GHCKey)
forall a. Monoid a => a
mempty
Just GHCKey
rep -> (GHCKey, GHCKey) -> Set (GHCKey, GHCKey)
forall a. a -> Set a
Set.singleton (GHCKey
rep, GHCKey
callee)
mkForest :: LexTree Loc RawDecl -> Forest RawDecl
mkForest :: LexTree Loc RawDecl -> Forest RawDecl
mkForest = Traversal
(Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
(Forest RawDecl)
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
RawDecl
-> ((String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> RawDecl)
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> Forest RawDecl
forall s t a b. Traversal s t a b -> (a -> b) -> s -> t
over forall a b. Traversal (Forest a) (Forest b) a b
Traversal
(Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
(Forest RawDecl)
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
RawDecl
forestT (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> RawDecl
fromKV (Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> Forest RawDecl)
-> (LexTree Loc RawDecl
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
-> LexTree Loc RawDecl
-> Forest RawDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forall k v. (Ord k, Semigroup v) => Forest (k, v) -> Forest (k, v)
dedup (Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
-> (LexTree Loc RawDecl
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
-> LexTree Loc RawDecl
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal
(Forest (Loc, RawDecl, Loc))
(Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
(Loc, RawDecl, Loc)
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> ((Loc, RawDecl, Loc)
-> (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
-> Forest (Loc, RawDecl, Loc)
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forall s t a b. Traversal s t a b -> (a -> b) -> s -> t
over forall a b. Traversal (Forest a) (Forest b) a b
Traversal
(Forest (Loc, RawDecl, Loc))
(Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
(Loc, RawDecl, Loc)
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forestT (Loc, RawDecl, Loc)
-> (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forall a c.
(a, RawDecl, c)
-> (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
toKV (Forest (Loc, RawDecl, Loc)
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc)))
-> (LexTree Loc RawDecl -> Forest (Loc, RawDecl, Loc))
-> LexTree Loc RawDecl
-> Forest
(String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexTree Loc RawDecl -> Forest (Loc, RawDecl, Loc)
forall p a. LexTree p a -> Forest (p, a, p)
LT.toForest
where
toKV :: (a, RawDecl, c)
-> (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
toKV (a
_, RawDecl String
name EnumSet GHCKey
keys DeclType
typ Loc
s Loc
e, c
_) = (String
name, (EnumSet GHCKey
keys, DeclType -> Max DeclType
forall a. a -> Max a
Max DeclType
typ, Loc -> First Loc
forall a. a -> First a
First Loc
s, Loc -> First Loc
forall a. a -> First a
First Loc
e))
fromKV :: (String, (EnumSet GHCKey, Max DeclType, First Loc, First Loc))
-> RawDecl
fromKV (String
name, (EnumSet GHCKey
keys, Max DeclType
typ, First Loc
s, First Loc
e)) = String -> EnumSet GHCKey -> DeclType -> Loc -> Loc -> RawDecl
RawDecl String
name EnumSet GHCKey
keys DeclType
typ Loc
s Loc
e
mkDecl :: EnumSet GHCKey -> RawDecl -> HieParse Decl
mkDecl :: EnumSet GHCKey
-> RawDecl
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl
mkDecl EnumSet GHCKey
exportSet (RawDecl String
str EnumSet GHCKey
ghcKeys DeclType
typ Loc
start Loc
_) = do
Key
key <- HieParse Key
fresh
[GHCKey]
-> (GHCKey
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ())
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
ghcKeys) (Key
-> GHCKey
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ()
assoc Key
key)
let exported :: Bool
exported = (GHCKey -> Bool) -> [GHCKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((GHCKey -> EnumSet GHCKey -> Bool)
-> EnumSet GHCKey -> GHCKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip GHCKey -> EnumSet GHCKey -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member EnumSet GHCKey
exportSet) (EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
ghcKeys)
Decl -> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decl -> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl)
-> Decl
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) Decl
forall a b. (a -> b) -> a -> b
$ String -> Key -> EnumSet GHCKey -> Bool -> DeclType -> Loc -> Decl
Decl String
str Key
key EnumSet GHCKey
ghcKeys Bool
exported DeclType
typ Loc
start
fresh :: HieParse Key
fresh :: HieParse Key
fresh = ((Key, EnumMap GHCKey Key) -> (Key, (Key, EnumMap GHCKey Key)))
-> HieParse Key
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((Key, EnumMap GHCKey Key) -> (Key, (Key, EnumMap GHCKey Key)))
-> HieParse Key)
-> ((Key, EnumMap GHCKey Key) -> (Key, (Key, EnumMap GHCKey Key)))
-> HieParse Key
forall a b. (a -> b) -> a -> b
$ \(Key Int
n, EnumMap GHCKey Key
m) -> (Int -> Key
Key Int
n, (Int -> Key
Key (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), EnumMap GHCKey Key
m))
assoc :: Key -> GHCKey -> HieParse ()
assoc :: Key
-> GHCKey
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ()
assoc Key
key GHCKey
ghckey = ((Key, EnumMap GHCKey Key) -> (Key, EnumMap GHCKey Key))
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Key, EnumMap GHCKey Key) -> (Key, EnumMap GHCKey Key))
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ())
-> ((Key, EnumMap GHCKey Key) -> (Key, EnumMap GHCKey Key))
-> StateT (Key, EnumMap GHCKey Key) (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ (EnumMap GHCKey Key -> EnumMap GHCKey Key)
-> (Key, EnumMap GHCKey Key) -> (Key, EnumMap GHCKey Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GHCKey -> Key -> EnumMap GHCKey Key -> EnumMap GHCKey Key
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insert GHCKey
ghckey Key
key)
dedup :: (Ord k, Semigroup v) => Forest (k, v) -> Forest (k, v)
dedup :: Forest (k, v) -> Forest (k, v)
dedup = Dedup k v -> Forest (k, v)
forall a b. Dedup a b -> Forest (a, b)
fromDedup (Dedup k v -> Forest (k, v))
-> (Forest (k, v) -> Dedup k v) -> Forest (k, v) -> Forest (k, v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest (k, v) -> Dedup k v
toDedup
where
fromDedup :: Dedup a b -> Forest (a, b)
fromDedup = ((a, (b, Dedup a b)) -> Tree (a, b))
-> [(a, (b, Dedup a b))] -> Forest (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
k, (b
v, Dedup a b
d)) -> (a, b) -> Forest (a, b) -> Tree (a, b)
forall a. a -> Forest a -> Tree a
Node (a
k, b
v) (Dedup a b -> Forest (a, b)
fromDedup Dedup a b
d)) ([(a, (b, Dedup a b))] -> Forest (a, b))
-> (Dedup a b -> [(a, (b, Dedup a b))])
-> Dedup a b
-> Forest (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (b, Dedup a b) -> [(a, (b, Dedup a b))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map a (b, Dedup a b) -> [(a, (b, Dedup a b))])
-> (Dedup a b -> Map a (b, Dedup a b))
-> Dedup a b
-> [(a, (b, Dedup a b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dedup a b -> Map a (b, Dedup a b)
forall k v. Dedup k v -> Map k (v, Dedup k v)
unDedup
toDedup :: Forest (k, v) -> Dedup k v
toDedup = Map k (v, Dedup k v) -> Dedup k v
forall k v. Map k (v, Dedup k v) -> Dedup k v
Dedup (Map k (v, Dedup k v) -> Dedup k v)
-> (Forest (k, v) -> Map k (v, Dedup k v))
-> Forest (k, v)
-> Dedup k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Dedup k v) -> (v, Dedup k v) -> (v, Dedup k v))
-> [(k, (v, Dedup k v))] -> Map k (v, Dedup k v)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (v, Dedup k v) -> (v, Dedup k v) -> (v, Dedup k v)
forall a. Semigroup a => a -> a -> a
(<>) ([(k, (v, Dedup k v))] -> Map k (v, Dedup k v))
-> (Forest (k, v) -> [(k, (v, Dedup k v))])
-> Forest (k, v)
-> Map k (v, Dedup k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (k, v) -> (k, (v, Dedup k v)))
-> Forest (k, v) -> [(k, (v, Dedup k v))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node (k
k, v
v) Forest (k, v)
f) -> (k
k, (v
v, Forest (k, v) -> Dedup k v
toDedup Forest (k, v)
f)))
newtype Dedup k v = Dedup {Dedup k v -> Map k (v, Dedup k v)
unDedup :: Map k (v, Dedup k v)}
instance (Ord k, Semigroup v) => Semigroup (Dedup k v) where
Dedup Map k (v, Dedup k v)
a <> :: Dedup k v -> Dedup k v -> Dedup k v
<> Dedup Map k (v, Dedup k v)
b = Map k (v, Dedup k v) -> Dedup k v
forall k v. Map k (v, Dedup k v) -> Dedup k v
Dedup (((v, Dedup k v) -> (v, Dedup k v) -> (v, Dedup k v))
-> Map k (v, Dedup k v)
-> Map k (v, Dedup k v)
-> Map k (v, Dedup k v)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (v, Dedup k v) -> (v, Dedup k v) -> (v, Dedup k v)
forall a. Semigroup a => a -> a -> a
(<>) Map k (v, Dedup k v)
a Map k (v, Dedup k v)
b)
structure :: [RawDecl] -> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
structure :: [RawDecl] -> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
structure = (LexTree Loc RawDecl
-> RawDecl -> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl))
-> LexTree Loc RawDecl
-> [RawDecl]
-> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ !LexTree Loc RawDecl
t RawDecl
decl -> (RawDecl -> RawDecl -> Maybe RawDecl)
-> Loc
-> RawDecl
-> Loc
-> LexTree Loc RawDecl
-> Either (TreeError Loc RawDecl) (LexTree Loc RawDecl)
forall p a.
Ord p =>
(a -> a -> Maybe a)
-> p
-> a
-> p
-> LexTree p a
-> Either (TreeError p a) (LexTree p a)
LT.insertWith RawDecl -> RawDecl -> Maybe RawDecl
f (RawDecl -> Loc
rdStart RawDecl
decl) RawDecl
decl (RawDecl -> Loc
rdEnd RawDecl
decl) LexTree Loc RawDecl
t) LexTree Loc RawDecl
forall p a. LexTree p a
LT.emptyLexTree
where
f :: RawDecl -> RawDecl -> Maybe RawDecl
f (RawDecl String
na EnumSet GHCKey
ka DeclType
ta Loc
sa Loc
ea) prev :: RawDecl
prev@(RawDecl String
nb EnumSet GHCKey
kb DeclType
tb Loc
_ Loc
_)
| DeclType
ta DeclType -> DeclType -> Bool
forall a. Eq a => a -> a -> Bool
== DeclType
tb Bool -> Bool -> Bool
&& String
na String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nb = RawDecl -> Maybe RawDecl
forall a. a -> Maybe a
Just (String -> EnumSet GHCKey -> DeclType -> Loc -> Loc -> RawDecl
RawDecl String
na (EnumSet GHCKey
ka EnumSet GHCKey -> EnumSet GHCKey -> EnumSet GHCKey
forall a. Semigroup a => a -> a -> a
<> EnumSet GHCKey
kb) DeclType
ta Loc
sa Loc
ea)
| Bool
otherwise = RawDecl -> Maybe RawDecl
forall a. a -> Maybe a
Just RawDecl
prev
isGenerated :: GHC.Name -> Bool
isGenerated :: Name -> Bool
isGenerated = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
'$' (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
GHC.getOccString
data Collect = Collect
{ Collect -> [RawDecl]
_decls :: [RawDecl],
Collect -> [(Loc, GHCKey)]
_uses :: [(Loc, GHCKey)],
Collect -> EnumMap GHCKey (EnumSet GHCKey)
_types :: EnumMap GHCKey (EnumSet GHCKey)
}
collect :: GHC.HieFile -> Collect
collect :: HieFile -> Collect
collect (GHC.HieFile String
_ Module
_ Array Int HieTypeFlat
typeArr (GHC.HieASTs Map FastString (HieAST Int)
asts) [AvailInfo]
_ ByteString
_) = State Collect () -> Collect -> Collect
forall s a. State s a -> s -> s
execState (Traversal
(Map FastString (HieAST Int)) (Map FastString Any) (HieAST Int) Any
-> Map FastString (HieAST Int)
-> (HieAST Int -> State Collect ())
-> State Collect ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ Traversal
(Map FastString (HieAST Int)) (Map FastString Any) (HieAST Int) Any
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Map FastString (HieAST Int)
asts HieAST Int -> State Collect ()
go) ([RawDecl]
-> [(Loc, GHCKey)] -> EnumMap GHCKey (EnumSet GHCKey) -> Collect
Collect [RawDecl]
forall a. Monoid a => a
mempty [(Loc, GHCKey)]
forall a. Monoid a => a
mempty EnumMap GHCKey (EnumSet GHCKey)
forall a. Monoid a => a
mempty)
where
tellDecl :: GHC.Name -> DeclType -> GHC.RealSrcSpan -> State Collect ()
tellDecl :: Name -> DeclType -> RealSrcSpan -> State Collect ()
tellDecl Name
nm DeclType
typ RealSrcSpan
spn = (Collect -> Collect) -> State Collect ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> State Collect ())
-> (Collect -> Collect) -> State Collect ()
forall a b. (a -> b) -> a -> b
$ \(Collect [RawDecl]
decls [(Loc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [RawDecl]
-> [(Loc, GHCKey)] -> EnumMap GHCKey (EnumSet GHCKey) -> Collect
Collect (RawDecl
decl RawDecl -> [RawDecl] -> [RawDecl]
forall a. a -> [a] -> [a]
: [RawDecl]
decls) [(Loc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types
where
decl :: RawDecl
decl =
String -> EnumSet GHCKey -> DeclType -> Loc -> Loc -> RawDecl
RawDecl
(Name -> String
forall a. NamedThing a => a -> String
GHC.getOccString Name
nm)
(GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (GHCKey -> EnumSet GHCKey)
-> (Name -> GHCKey) -> Name -> EnumSet GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> GHCKey
ghcNameKey (Name -> EnumSet GHCKey) -> Name -> EnumSet GHCKey
forall a b. (a -> b) -> a -> b
$ Name
nm)
DeclType
typ
(Int -> Int -> Loc
Loc (RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
spn) (RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
spn))
(Int -> Int -> Loc
Loc (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
spn) (RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
spn))
tellUse :: GHC.RealSrcLoc -> GHCKey -> State Collect ()
tellUse :: RealSrcLoc -> GHCKey -> State Collect ()
tellUse RealSrcLoc
loc GHCKey
key = (Collect -> Collect) -> State Collect ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> State Collect ())
-> (Collect -> Collect) -> State Collect ()
forall a b. (a -> b) -> a -> b
$ \(Collect [RawDecl]
decls [(Loc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [RawDecl]
-> [(Loc, GHCKey)] -> EnumMap GHCKey (EnumSet GHCKey) -> Collect
Collect [RawDecl]
decls ((Int -> Int -> Loc
Loc (RealSrcLoc -> Int
GHC.srcLocLine RealSrcLoc
loc) (RealSrcLoc -> Int
GHC.srcLocCol RealSrcLoc
loc), GHCKey
key) (Loc, GHCKey) -> [(Loc, GHCKey)] -> [(Loc, GHCKey)]
forall a. a -> [a] -> [a]
: [(Loc, GHCKey)]
uses) EnumMap GHCKey (EnumSet GHCKey)
types
tellType :: GHC.Name -> GHC.TypeIndex -> State Collect ()
tellType :: Name -> Int -> State Collect ()
tellType Name
name Int
ix = (Collect -> Collect) -> State Collect ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> State Collect ())
-> (Collect -> Collect) -> State Collect ()
forall a b. (a -> b) -> a -> b
$ \(Collect [RawDecl]
decls [(Loc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [RawDecl]
-> [(Loc, GHCKey)] -> EnumMap GHCKey (EnumSet GHCKey) -> Collect
Collect [RawDecl]
decls [(Loc, GHCKey)]
uses ((EnumSet GHCKey -> EnumSet GHCKey -> EnumSet GHCKey)
-> GHCKey
-> EnumSet GHCKey
-> EnumMap GHCKey (EnumSet GHCKey)
-> EnumMap GHCKey (EnumSet GHCKey)
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insertWith EnumSet GHCKey -> EnumSet GHCKey -> EnumSet GHCKey
forall a. Semigroup a => a -> a -> a
(<>) (Name -> GHCKey
ghcNameKey Name
name) (EnumMap Int (EnumSet GHCKey)
typeMap EnumMap Int (EnumSet GHCKey) -> Int -> EnumSet GHCKey
forall k a. Enum k => EnumMap k a -> k -> a
EnumMap.! Int
ix) EnumMap GHCKey (EnumSet GHCKey)
types)
typeMap :: EnumMap Int (EnumSet GHCKey)
typeMap = Array Int HieTypeFlat -> EnumMap Int (EnumSet GHCKey)
resolveTypes Array Int HieTypeFlat
typeArr
ignoreNode :: NodeInfo a -> Bool
ignoreNode NodeInfo a
nodeInfo = ((NodeInfo a -> Bool) -> Bool) -> [NodeInfo a -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NodeInfo a -> Bool) -> NodeInfo a -> Bool
forall a b. (a -> b) -> a -> b
$ NodeInfo a
nodeInfo) [NodeInfo a -> Bool
forall a. NodeInfo a -> Bool
isInstanceNode, NodeInfo a -> Bool
forall a. NodeInfo a -> Bool
isTypeSignatureNode, NodeInfo a -> Bool
forall a. NodeInfo a -> Bool
isInlineNode, NodeInfo a -> Bool
forall a. NodeInfo a -> Bool
isMinimalNode, NodeInfo a -> Bool
forall a. NodeInfo a -> Bool
isDerivingNode]
go :: GHC.HieAST GHC.TypeIndex -> State Collect ()
go :: HieAST Int -> State Collect ()
go node :: HieAST Int
node@(GHC.Node NodeInfo Int
_ RealSrcSpan
_ [HieAST Int]
children) =
Traversal (HieAST Int) (HieAST Int) (NodeInfo Int) (NodeInfo Int)
-> HieAST Int
-> (NodeInfo Int -> State Collect ())
-> State Collect ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ forall a. Traversal' (HieAST a) (NodeInfo a)
Traversal (HieAST Int) (HieAST Int) (NodeInfo Int) (NodeInfo Int)
sourceInfo HieAST Int
node ((NodeInfo Int -> State Collect ()) -> State Collect ())
-> (NodeInfo Int -> State Collect ()) -> State Collect ()
forall a b. (a -> b) -> a -> b
$ \NodeInfo Int
nodeInfo ->
Bool -> State Collect () -> State Collect ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NodeInfo Int -> Bool
forall a. NodeInfo a -> Bool
ignoreNode NodeInfo Int
nodeInfo) (State Collect () -> State Collect ())
-> State Collect () -> State Collect ()
forall a b. (a -> b) -> a -> b
$ do
[(Identifier, IdentifierDetails Int)]
-> ((Identifier, IdentifierDetails Int) -> State Collect ())
-> State Collect ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Identifier (IdentifierDetails Int)
-> [(Identifier, IdentifierDetails Int)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Identifier (IdentifierDetails Int)
-> [(Identifier, IdentifierDetails Int)])
-> Map Identifier (IdentifierDetails Int)
-> [(Identifier, IdentifierDetails Int)]
forall a b. (a -> b) -> a -> b
$ NodeInfo Int -> Map Identifier (IdentifierDetails Int)
forall a. NodeInfo a -> NodeIdentifiers a
GHC.nodeIdentifiers NodeInfo Int
nodeInfo) (((Identifier, IdentifierDetails Int) -> State Collect ())
-> State Collect ())
-> ((Identifier, IdentifierDetails Int) -> State Collect ())
-> State Collect ()
forall a b. (a -> b) -> a -> b
$ \case
(Right Name
name, GHC.IdentifierDetails Maybe Int
ty Set ContextInfo
info) | Bool -> Bool
not (Name -> Bool
isGenerated Name
name) -> do
(Int -> State Collect ()) -> Maybe Int -> State Collect ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name -> Int -> State Collect ()
tellType Name
name) Maybe Int
ty
case Set ContextInfo -> IdentifierType
classifyIdentifier Set ContextInfo
info of
IdentifierType
IdnIgnore -> () -> State Collect ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IdentifierType
IdnUse -> RealSrcLoc -> GHCKey -> State Collect ()
tellUse (RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanStart (RealSrcSpan -> RealSrcLoc) -> RealSrcSpan -> RealSrcLoc
forall a b. (a -> b) -> a -> b
$ HieAST Int -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
GHC.nodeSpan HieAST Int
node) (Name -> GHCKey
ghcNameKey Name
name)
IdnDecl DeclType
typ RealSrcSpan
sp
| RealSrcSpan -> Bool
GHC.isPointSpan RealSrcSpan
sp -> () -> State Collect ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise -> Name -> DeclType -> RealSrcSpan -> State Collect ()
tellDecl Name
name DeclType
typ RealSrcSpan
sp
(Identifier, IdentifierDetails Int)
_ -> () -> State Collect ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(HieAST Int -> State Collect ())
-> [HieAST Int] -> State Collect ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HieAST Int -> State Collect ()
go [HieAST Int]
children
resolveTypes :: Array GHC.TypeIndex GHC.HieTypeFlat -> EnumMap GHC.TypeIndex (EnumSet GHCKey)
resolveTypes :: Array Int HieTypeFlat -> EnumMap Int (EnumSet GHCKey)
resolveTypes Array Int HieTypeFlat
typeArray = [(Int, EnumSet GHCKey)] -> EnumMap Int (EnumSet GHCKey)
forall k a. Enum k => [(k, a)] -> EnumMap k a
EnumMap.fromList [(Int
ix, State (EnumSet Int) (EnumSet GHCKey)
-> EnumSet Int -> EnumSet GHCKey
forall s a. State s a -> s -> a
evalState (Int -> State (EnumSet Int) (EnumSet GHCKey)
go Int
ix) EnumSet Int
forall a. Monoid a => a
mempty) | Int
ix <- Array Int HieTypeFlat -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices Array Int HieTypeFlat
typeArray]
where
keys :: GHC.HieType a -> EnumSet GHCKey
keys :: HieType a -> EnumSet GHCKey
keys (GHC.HTyConApp (GHC.IfaceTyCon Name
name IfaceTyConInfo
_) HieArgs a
_) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (Name -> GHCKey
ghcNameKey Name
name)
keys (GHC.HForAllTy ((Name
name, a
_), ArgFlag
_) a
_) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (Name -> GHCKey
ghcNameKey Name
name)
keys (GHC.HTyVarTy Name
name) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (Name -> GHCKey
ghcNameKey Name
name)
keys HieType a
_ = EnumSet GHCKey
forall a. Monoid a => a
mempty
go :: GHC.TypeIndex -> State (EnumSet GHC.TypeIndex) (EnumSet GHCKey)
go :: Int -> State (EnumSet Int) (EnumSet GHCKey)
go Int
current =
(EnumSet Int -> Bool) -> StateT (EnumSet Int) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> EnumSet Int -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Int
current) StateT (EnumSet Int) Identity Bool
-> (Bool -> State (EnumSet Int) (EnumSet GHCKey))
-> State (EnumSet Int) (EnumSet GHCKey)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> EnumSet GHCKey -> State (EnumSet Int) (EnumSet GHCKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumSet GHCKey
forall a. Monoid a => a
mempty
Bool
False -> do
(EnumSet Int -> EnumSet Int) -> StateT (EnumSet Int) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int -> EnumSet Int -> EnumSet Int
forall k. Enum k => k -> EnumSet k -> EnumSet k
EnumSet.insert Int
current)
let ty :: HieTypeFlat
ty = Array Int HieTypeFlat
typeArray Array Int HieTypeFlat -> Int -> HieTypeFlat
forall i e. Ix i => Array i e -> i -> e
Array.! Int
current
EnumSet GHCKey -> EnumSet GHCKey -> EnumSet GHCKey
forall a. Monoid a => a -> a -> a
mappend (HieTypeFlat -> EnumSet GHCKey
forall a. HieType a -> EnumSet GHCKey
keys HieTypeFlat
ty) (EnumSet GHCKey -> EnumSet GHCKey)
-> ([EnumSet GHCKey] -> EnumSet GHCKey)
-> [EnumSet GHCKey]
-> EnumSet GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EnumSet GHCKey] -> EnumSet GHCKey
forall a. Monoid a => [a] -> a
mconcat ([EnumSet GHCKey] -> EnumSet GHCKey)
-> StateT (EnumSet Int) Identity [EnumSet GHCKey]
-> State (EnumSet Int) (EnumSet GHCKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> State (EnumSet Int) (EnumSet GHCKey))
-> [Int] -> StateT (EnumSet Int) Identity [EnumSet GHCKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> State (EnumSet Int) (EnumSet GHCKey)
go (HieTypeFlat -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList HieTypeFlat
ty)
data IdentifierType
= IdnDecl !DeclType !GHC.Span
| IdnUse
| IdnIgnore
instance Semigroup IdentifierType where
IdentifierType
IdnIgnore <> :: IdentifierType -> IdentifierType -> IdentifierType
<> IdentifierType
a = IdentifierType
a
IdentifierType
IdnUse <> IdentifierType
IdnIgnore = IdentifierType
IdnUse
IdentifierType
IdnUse <> IdentifierType
a = IdentifierType
a
IdnDecl DeclType
typ RealSrcSpan
sp <> IdnDecl DeclType
typ' RealSrcSpan
sp' = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl (DeclType -> DeclType -> DeclType
forall a. Ord a => a -> a -> a
max DeclType
typ DeclType
typ') (RealSrcSpan -> RealSrcSpan -> RealSrcSpan
mergeSpans RealSrcSpan
sp RealSrcSpan
sp')
IdnDecl DeclType
typ RealSrcSpan
sp <> IdentifierType
_ = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
typ RealSrcSpan
sp
instance Monoid IdentifierType where mempty :: IdentifierType
mempty = IdentifierType
IdnIgnore
classifyIdentifier :: Set GHC.ContextInfo -> IdentifierType
classifyIdentifier :: Set ContextInfo -> IdentifierType
classifyIdentifier = (ContextInfo -> IdentifierType)
-> Set ContextInfo -> IdentifierType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ContextInfo -> IdentifierType
classify
where
classify :: GHC.ContextInfo -> IdentifierType
classify :: ContextInfo -> IdentifierType
classify (GHC.Decl DeclType
GHC.DataDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
DataDecl RealSrcSpan
sp
classify (GHC.Decl DeclType
GHC.PatSynDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
DataDecl RealSrcSpan
sp
classify (GHC.Decl DeclType
GHC.FamDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
DataDecl RealSrcSpan
sp
classify (GHC.Decl DeclType
GHC.SynDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
DataDecl RealSrcSpan
sp
classify (GHC.Decl DeclType
GHC.ConDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
ConDecl RealSrcSpan
sp
classify (GHC.Decl DeclType
GHC.ClassDec (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
ClassDecl RealSrcSpan
sp
classify (GHC.ClassTyDecl (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
ValueDecl RealSrcSpan
sp
classify (GHC.ValBind BindType
GHC.RegularBind Scope
_ (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
ValueDecl RealSrcSpan
sp
classify (GHC.RecField RecFieldContext
GHC.RecFieldDecl (Just RealSrcSpan
sp)) = DeclType -> RealSrcSpan -> IdentifierType
IdnDecl DeclType
RecDecl RealSrcSpan
sp
classify (GHC.RecField RecFieldContext
GHC.RecFieldAssign Maybe RealSrcSpan
_) = IdentifierType
IdnUse
classify (GHC.RecField RecFieldContext
GHC.RecFieldOcc Maybe RealSrcSpan
_) = IdentifierType
IdnUse
classify ContextInfo
GHC.Use = IdentifierType
IdnUse
classify ContextInfo
_ = IdentifierType
IdnIgnore