{-# 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 (..))

-- | A declaration extracted from the source code.
--
-- A single symbol can apparently declare a name multiple times in the same place, with multiple distinct keys D:
-- This happens, for example, with default methods; the name refers to both the method name and the default implementation's name.
-- We have to account for that to _some_ degree, which is why keys is a set.
-- The actual resolution of these happens wit 'dedup' in mkForest
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
  }

-- | Assigns and maintains a mapping of GHCKeys to Key
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

    -- TODO this is the only part that touches the state, maybe it's worth lifting it out
    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

-- | This is the best way I can find of checking whether the name was written by a programmer or not.
-- GHC internally classifies names extensively, but none of those mechanisms seem to allow to distinguish GHC-generated names.
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 declarations, uses, and types in a HIE file
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

-- TODO This can be faster by storing intermediate restuls, but that has proven tricky to get right.
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)
    -- These are variables, which we ignore, but it can't hurt
    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
    -- Use
    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
    -- Ignore
    classify ContextInfo
_ = IdentifierType
IdnIgnore