{-# 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, sourceInfo, spanSpans)
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.Bifunctor (first)
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.Set (Set)
import qualified Data.Set as Set
import Data.Tree (Forest)
import qualified Data.Tree as Tree

-- 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 TypeIndex HieTypeFlat -> EnumMap TypeIndex (EnumSet GHCKey)
resolveTypes Array TypeIndex HieTypeFlat
typeArray = [(TypeIndex, EnumSet GHCKey)] -> EnumMap TypeIndex (EnumSet GHCKey)
forall k a. Enum k => [(k, a)] -> EnumMap k a
EnumMap.fromList [(TypeIndex
ix, State (EnumSet TypeIndex) (EnumSet GHCKey)
-> EnumSet TypeIndex -> EnumSet GHCKey
forall s a. State s a -> s -> a
evalState (TypeIndex -> State (EnumSet TypeIndex) (EnumSet GHCKey)
go TypeIndex
ix) EnumSet TypeIndex
forall a. Monoid a => a
mempty) | TypeIndex
ix <- Array TypeIndex HieTypeFlat -> [TypeIndex]
forall i e. Ix i => Array i e -> [i]
Array.indices Array TypeIndex HieTypeFlat
typeArray]
  where
    keys :: GHC.HieType a -> EnumSet GHCKey
    keys :: HieType a -> EnumSet GHCKey
keys (GHC.HTyConApp (GHC.IfaceTyCon IfExtName
name IfaceTyConInfo
_) HieArgs a
_) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (IfExtName -> GHCKey
ghcNameKey IfExtName
name)
    keys (GHC.HForAllTy ((IfExtName
name, a
_), ArgFlag
_) a
_) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (IfExtName -> GHCKey
ghcNameKey IfExtName
name)
    -- These are variables, which we ignore, but it can't hurt
    keys (GHC.HTyVarTy IfExtName
name) = GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (IfExtName -> GHCKey
ghcNameKey IfExtName
name)
    keys HieType a
_ = EnumSet GHCKey
forall a. Monoid a => a
mempty
    go :: GHC.TypeIndex -> State (EnumSet GHC.TypeIndex) (EnumSet GHCKey)
    go :: TypeIndex -> State (EnumSet TypeIndex) (EnumSet GHCKey)
go TypeIndex
current =
      (EnumSet TypeIndex -> Bool)
-> StateT (EnumSet TypeIndex) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TypeIndex -> EnumSet TypeIndex -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member TypeIndex
current) StateT (EnumSet TypeIndex) Identity Bool
-> (Bool -> State (EnumSet TypeIndex) (EnumSet GHCKey))
-> State (EnumSet TypeIndex) (EnumSet GHCKey)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> EnumSet GHCKey -> State (EnumSet TypeIndex) (EnumSet GHCKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumSet GHCKey
forall a. Monoid a => a
mempty
        Bool
False -> do
          (EnumSet TypeIndex -> EnumSet TypeIndex)
-> StateT (EnumSet TypeIndex) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TypeIndex -> EnumSet TypeIndex -> EnumSet TypeIndex
forall k. Enum k => k -> EnumSet k -> EnumSet k
EnumSet.insert TypeIndex
current)
          let ty :: HieTypeFlat
ty = Array TypeIndex HieTypeFlat
typeArray Array TypeIndex HieTypeFlat -> TypeIndex -> HieTypeFlat
forall i e. Ix i => Array i e -> i -> e
Array.! TypeIndex
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 TypeIndex) Identity [EnumSet GHCKey]
-> State (EnumSet TypeIndex) (EnumSet GHCKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeIndex -> State (EnumSet TypeIndex) (EnumSet GHCKey))
-> [TypeIndex]
-> StateT (EnumSet TypeIndex) Identity [EnumSet GHCKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeIndex -> State (EnumSet TypeIndex) (EnumSet GHCKey)
go (HieTypeFlat -> [TypeIndex]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList HieTypeFlat
ty)

type GHCDecl = (DeclType, GHC.Span, GHC.Name, Loc)

data Collect = Collect
  { Collect -> [GHCDecl]
_decls :: [GHCDecl],
    Collect -> [(RealSrcLoc, GHCKey)]
_uses :: [(GHC.RealSrcLoc, GHCKey)],
    Collect -> EnumMap GHCKey (EnumSet GHCKey)
_types :: EnumMap GHCKey (EnumSet GHCKey)
  }

newtype ParseError = TreeError (TreeError GHC.RealSrcLoc (DeclType, Name, Loc))

ppParseError :: Prints ParseError
ppParseError :: Prints ParseError
ppParseError (TreeError TreeError RealSrcLoc (DeclType, Name, Loc)
err) = Prints (TreeError RealSrcLoc (DeclType, Name, Loc))
ppTreeError TreeError RealSrcLoc (DeclType, Name, Loc)
err
  where
    ppTreeError :: Prints (TreeError GHC.RealSrcLoc (DeclType, Name, Loc))
    ppTreeError :: Prints (TreeError RealSrcLoc (DeclType, Name, Loc))
ppTreeError (InvalidBounds RealSrcLoc
l (DeclType
ty, Name
nm, Loc
_) RealSrcLoc
r) = String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Invalid bounds:" Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (RealSrcLoc -> RealSrcLoc -> DeclType -> Name -> Printer ()
ppLocNode RealSrcLoc
l RealSrcLoc
r DeclType
ty Name
nm)
    ppTreeError (OverlappingBounds (DeclType
ty, Name
nm, Loc
_) (DeclType
ty', Name
nm', Loc
_) RealSrcLoc
l RealSrcLoc
r) = do
      String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"OverlappingBounds bounds: (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (RealSrcLoc, RealSrcLoc) -> String
forall a. Show a => a -> String
show (RealSrcLoc
l, RealSrcLoc
r) 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
$ do
        String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ Name -> String
showName Name
nm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DeclType -> String
forall a. Show a => a -> String
show DeclType
ty String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
        String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ Name -> String
showName Name
nm' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DeclType -> String
forall a. Show a => a -> String
show DeclType
ty' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    ppTreeError TreeError RealSrcLoc (DeclType, Name, Loc)
MidSplit = String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"MidSplit"
    ppTreeError (LexicalError RealSrcLoc
l (DeclType
ty, Name
nm, Loc
_) RealSrcLoc
r LexTree RealSrcLoc (DeclType, Name, Loc)
t) = do
      String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn String
"Lexical error"
      Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ do
        RealSrcLoc -> RealSrcLoc -> DeclType -> Name -> Printer ()
ppLocNode RealSrcLoc
l RealSrcLoc
r DeclType
ty Name
nm
        Prints (LexTree RealSrcLoc (DeclType, Name, Loc))
ppLexTree LexTree RealSrcLoc (DeclType, Name, Loc)
t

showName :: Name -> String
showName :: Name -> String
showName (Name String
name EnumSet GHCKey
keys) = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [GHCKey] -> String
forall a. Show a => a -> String
show (EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
keys)

ppLocNode :: GHC.RealSrcLoc -> GHC.RealSrcLoc -> DeclType -> Name -> Printer ()
ppLocNode :: RealSrcLoc -> RealSrcLoc -> DeclType -> Name -> Printer ()
ppLocNode RealSrcLoc
l RealSrcLoc
r DeclType
typ Name
name = String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ Name -> String
showName Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DeclType -> String
forall a. Show a => a -> String
show DeclType
typ String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RealSrcLoc -> String
forall a. Show a => a -> String
show RealSrcLoc
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RealSrcLoc -> String
forall a. Show a => a -> String
show RealSrcLoc
r

ppLexTree :: Prints (LexTree GHC.RealSrcLoc (DeclType, Name, Loc))
ppLexTree :: Prints (LexTree RealSrcLoc (DeclType, Name, Loc))
ppLexTree = Printer ()
-> (Printer ()
    -> RealSrcLoc
    -> (DeclType, Name, Loc)
    -> Printer ()
    -> RealSrcLoc
    -> Printer ()
    -> Printer ())
-> Prints (LexTree RealSrcLoc (DeclType, Name, Loc))
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 ()
  -> RealSrcLoc
  -> (DeclType, Name, Loc)
  -> Printer ()
  -> RealSrcLoc
  -> Printer ()
  -> Printer ())
 -> Prints (LexTree RealSrcLoc (DeclType, Name, Loc)))
-> (Printer ()
    -> RealSrcLoc
    -> (DeclType, Name, Loc)
    -> Printer ()
    -> RealSrcLoc
    -> Printer ()
    -> Printer ())
-> Prints (LexTree RealSrcLoc (DeclType, Name, Loc))
forall a b. (a -> b) -> a -> b
$ \Printer ()
ls RealSrcLoc
l (DeclType
typ, Name
name, Loc
_loc) Printer ()
m RealSrcLoc
r Printer ()
rs -> do
  Printer ()
ls
  RealSrcLoc -> RealSrcLoc -> DeclType -> Name -> Printer ()
ppLocNode RealSrcLoc
l RealSrcLoc
r DeclType
typ Name
name
  Printer () -> Printer ()
forall (m :: * -> *) a. MonadPrint m => m a -> m a
indent Printer ()
m
  Printer ()
rs

-- A single symbol can apparently declare a name multiple times in the same place, with multiple distinct keys D:
data Name = Name
  { Name -> String
_nameString :: String,
    Name -> EnumSet GHCKey
nameKeys :: EnumSet GHCKey
  }
  deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord)

mkName :: GHC.Name -> Name
mkName :: IfExtName -> Name
mkName IfExtName
nm = String -> EnumSet GHCKey -> Name
Name (IfExtName -> String
forall a. NamedThing a => a -> String
GHC.getOccString IfExtName
nm) (GHCKey -> EnumSet GHCKey
forall k. Enum k => k -> EnumSet k
EnumSet.singleton (GHCKey -> EnumSet GHCKey) -> GHCKey -> EnumSet GHCKey
forall a b. (a -> b) -> a -> b
$ IfExtName -> GHCKey
ghcNameKey IfExtName
nm)

ghcNameKey :: GHC.Name -> GHCKey
ghcNameKey :: IfExtName -> GHCKey
ghcNameKey = TypeIndex -> GHCKey
GHCKey (TypeIndex -> GHCKey)
-> (IfExtName -> TypeIndex) -> IfExtName -> GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> TypeIndex
GHC.getKey (Unique -> TypeIndex)
-> (IfExtName -> Unique) -> IfExtName -> TypeIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfExtName -> Unique
GHC.nameUnique

-- TODO rename, clean up
newtype ParsePhaseDebugInfo = ParsePhaseDebugInfo
  { ParsePhaseDebugInfo
-> [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
modulesLexTrees :: [(String, LexTree GHC.RealSrcLoc (DeclType, Name, Loc))]
  }

ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo
ppParsePhaseDebugInfo :: Prints ParsePhaseDebugInfo
ppParsePhaseDebugInfo (ParsePhaseDebugInfo [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
mods) = [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
-> ((String, LexTree RealSrcLoc (DeclType, Name, Loc))
    -> Printer ())
-> Printer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
mods (((String, LexTree RealSrcLoc (DeclType, Name, Loc)) -> Printer ())
 -> Printer ())
-> ((String, LexTree RealSrcLoc (DeclType, Name, Loc))
    -> Printer ())
-> Printer ()
forall a b. (a -> b) -> a -> b
$ \(String
modName, LexTree RealSrcLoc (DeclType, Name, Loc)
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 RealSrcLoc (DeclType, Name, Loc))
ppLexTree LexTree RealSrcLoc (DeclType, Name, Loc)
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 RealSrcLoc (DeclType, Name, Loc)
_pfDebugTree :: LexTree GHC.RealSrcLoc (DeclType, Name, Loc)
  }

parseHieFiles ::
  [GHC.HieFile] ->
  Either ParseError (ParsePhaseDebugInfo, CallGraph)
parseHieFiles :: [HieFile] -> Either ParseError (ParsePhaseDebugInfo, CallGraph)
parseHieFiles [HieFile]
files = do
  ([ParsedFile]
parsed, (TypeIndex
_, EnumMap GHCKey Key
keymap)) <- StateT
  (TypeIndex, EnumMap GHCKey Key) (Either ParseError) [ParsedFile]
-> (TypeIndex, EnumMap GHCKey Key)
-> Either
     ParseError ([ParsedFile], (TypeIndex, EnumMap GHCKey Key))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((HieFile
 -> StateT
      (TypeIndex, EnumMap GHCKey Key) (Either ParseError) ParsedFile)
-> [HieFile]
-> StateT
     (TypeIndex, 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
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) ParsedFile
parseFile [HieFile]
files) (TypeIndex
0, EnumMap GHCKey Key
forall a. Monoid a => a
mempty)
  let ([Module]
mods, [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
debugs, [Set (GHCKey, GHCKey)]
calls, [EnumMap GHCKey (EnumSet GHCKey)]
typings) = [(Module, (String, LexTree RealSrcLoc (DeclType, Name, Loc)),
  Set (GHCKey, GHCKey), EnumMap GHCKey (EnumSet GHCKey))]
-> ([Module], [(String, LexTree RealSrcLoc (DeclType, Name, Loc))],
    [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 RealSrcLoc (DeclType, Name, Loc)),
     Set (GHCKey, GHCKey), EnumMap GHCKey (EnumSet GHCKey)))
-> [ParsedFile]
-> [(Module, (String, LexTree RealSrcLoc (DeclType, Name, Loc)),
     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
forest Set (GHCKey, GHCKey)
call EnumMap GHCKey (EnumSet GHCKey)
typing LexTree RealSrcLoc (DeclType, Name, Loc)
ltree) -> (String -> String -> Forest Decl -> Module
Module String
name String
path Forest Decl
forest, (String
name, LexTree RealSrcLoc (DeclType, Name, Loc)
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)
  (ParsePhaseDebugInfo, CallGraph)
-> Either ParseError (ParsePhaseDebugInfo, CallGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
-> ParsePhaseDebugInfo
ParsePhaseDebugInfo [(String, LexTree RealSrcLoc (DeclType, Name, Loc))]
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)
  where
    parseFile ::
      GHC.HieFile ->
      StateT
        (Int, EnumMap GHCKey Key)
        (Either ParseError)
        ParsedFile
    parseFile :: HieFile
-> StateT
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) ParsedFile
parseFile file :: HieFile
file@(GHC.HieFile String
filepath Module
mdl Array TypeIndex HieTypeFlat
_ HieASTs TypeIndex
_ [AvailInfo]
avails ByteString
_) = do
      Collect [GHCDecl]
decls [(RealSrcLoc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types <- Either ParseError Collect
-> StateT
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) Collect
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ParseError Collect
 -> StateT
      (TypeIndex, EnumMap GHCKey Key) (Either ParseError) Collect)
-> Either ParseError Collect
-> StateT
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) Collect
forall a b. (a -> b) -> a -> b
$ HieFile -> Either ParseError Collect
collect HieFile
file
      LexTree RealSrcLoc (DeclType, Name, Loc)
tree <- Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
-> StateT
     (TypeIndex, EnumMap GHCKey Key)
     (Either ParseError)
     (LexTree RealSrcLoc (DeclType, Name, Loc))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
 -> StateT
      (TypeIndex, EnumMap GHCKey Key)
      (Either ParseError)
      (LexTree RealSrcLoc (DeclType, Name, Loc)))
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
-> StateT
     (TypeIndex, EnumMap GHCKey Key)
     (Either ParseError)
     (LexTree RealSrcLoc (DeclType, Name, Loc))
forall a b. (a -> b) -> a -> b
$ [GHCDecl]
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
structure [GHCDecl]
decls
      let Set (GHCKey, GHCKey)
calls :: Set (GHCKey, GHCKey) = (((RealSrcLoc, GHCKey) -> Set (GHCKey, GHCKey))
 -> [(RealSrcLoc, GHCKey)] -> Set (GHCKey, GHCKey))
-> [(RealSrcLoc, GHCKey)]
-> ((RealSrcLoc, GHCKey) -> Set (GHCKey, GHCKey))
-> Set (GHCKey, GHCKey)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((RealSrcLoc, GHCKey) -> Set (GHCKey, GHCKey))
-> [(RealSrcLoc, GHCKey)] -> Set (GHCKey, GHCKey)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(RealSrcLoc, GHCKey)]
uses (((RealSrcLoc, GHCKey) -> Set (GHCKey, GHCKey))
 -> Set (GHCKey, GHCKey))
-> ((RealSrcLoc, GHCKey) -> Set (GHCKey, GHCKey))
-> Set (GHCKey, GHCKey)
forall a b. (a -> b) -> a -> b
$ \(RealSrcLoc
loc, GHCKey
callee) ->
            case RealSrcLoc
-> LexTree RealSrcLoc (DeclType, Name, Loc)
-> Maybe (DeclType, Name, Loc)
forall p a. Ord p => p -> LexTree p a -> Maybe a
LT.lookup RealSrcLoc
loc LexTree RealSrcLoc (DeclType, Name, Loc)
tree of
              Maybe (DeclType, Name, Loc)
Nothing -> Set (GHCKey, GHCKey)
forall a. Monoid a => a
mempty
              Just (DeclType
_, Name
callerName, Loc
_) -> (GHCKey, GHCKey) -> Set (GHCKey, GHCKey)
forall a. a -> Set a
Set.singleton (Name -> GHCKey
nameKey Name
callerName, GHCKey
callee)
      let 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
$ (IfExtName -> GHCKey) -> [IfExtName] -> [GHCKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IfExtName -> GHCKey
ghcNameKey ([IfExtName] -> [GHCKey]) -> [IfExtName] -> [GHCKey]
forall a b. (a -> b) -> a -> b
$ [AvailInfo]
avails [AvailInfo] -> (AvailInfo -> [IfExtName]) -> [IfExtName]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AvailInfo -> [IfExtName]
GHC.availNames
      Forest Decl
forest <- EnumSet GHCKey
-> NameTree
-> StateT
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) (Forest Decl)
forall (m :: * -> *).
Monad m =>
EnumSet GHCKey
-> NameTree
-> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
rekey EnumSet GHCKey
exportKeys (LexTree RealSrcLoc (DeclType, Name, Loc) -> NameTree
deduplicate LexTree RealSrcLoc (DeclType, Name, Loc)
tree)
      ParsedFile
-> StateT
     (TypeIndex, EnumMap GHCKey Key) (Either ParseError) ParsedFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedFile
 -> StateT
      (TypeIndex, EnumMap GHCKey Key) (Either ParseError) ParsedFile)
-> ParsedFile
-> StateT
     (TypeIndex, 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 RealSrcLoc (DeclType, Name, Loc)
-> ParsedFile
ParsedFile (ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
GHC.moduleName Module
mdl)) String
filepath Forest Decl
forest Set (GHCKey, GHCKey)
calls EnumMap GHCKey (EnumSet GHCKey)
types LexTree RealSrcLoc (DeclType, Name, Loc)
tree
    nameKey :: Name -> GHCKey
    nameKey :: Name -> GHCKey
nameKey = EnumSet GHCKey -> GHCKey
forall k. Enum k => EnumSet k -> k
EnumSet.findMin (EnumSet GHCKey -> GHCKey)
-> (Name -> EnumSet GHCKey) -> Name -> GHCKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> EnumSet GHCKey
nameKeys

rekey :: forall m. Monad m => EnumSet GHCKey -> NameTree -> StateT (Int, EnumMap GHCKey Key) m (Forest Decl)
rekey :: EnumSet GHCKey
-> NameTree
-> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
rekey EnumSet GHCKey
exports = NameTree -> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
go
  where
    fresh :: StateT (Int, EnumMap GHCKey Key) m Key
    fresh :: StateT (TypeIndex, EnumMap GHCKey Key) m Key
fresh = ((TypeIndex, EnumMap GHCKey Key)
 -> (Key, (TypeIndex, EnumMap GHCKey Key)))
-> StateT (TypeIndex, EnumMap GHCKey Key) m Key
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((TypeIndex, EnumMap GHCKey Key)
  -> (Key, (TypeIndex, EnumMap GHCKey Key)))
 -> StateT (TypeIndex, EnumMap GHCKey Key) m Key)
-> ((TypeIndex, EnumMap GHCKey Key)
    -> (Key, (TypeIndex, EnumMap GHCKey Key)))
-> StateT (TypeIndex, EnumMap GHCKey Key) m Key
forall a b. (a -> b) -> a -> b
$ \(TypeIndex
n, EnumMap GHCKey Key
m) -> (TypeIndex -> Key
Key TypeIndex
n, (TypeIndex
n TypeIndex -> TypeIndex -> TypeIndex
forall a. Num a => a -> a -> a
+ TypeIndex
1, EnumMap GHCKey Key
m))
    assoc :: Key -> GHCKey -> StateT (Int, EnumMap GHCKey Key) m ()
    assoc :: Key -> GHCKey -> StateT (TypeIndex, EnumMap GHCKey Key) m ()
assoc Key
key GHCKey
ghckey = ((TypeIndex, EnumMap GHCKey Key)
 -> (TypeIndex, EnumMap GHCKey Key))
-> StateT (TypeIndex, EnumMap GHCKey Key) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((TypeIndex, EnumMap GHCKey Key)
  -> (TypeIndex, EnumMap GHCKey Key))
 -> StateT (TypeIndex, EnumMap GHCKey Key) m ())
-> ((TypeIndex, EnumMap GHCKey Key)
    -> (TypeIndex, EnumMap GHCKey Key))
-> StateT (TypeIndex, EnumMap GHCKey Key) m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap GHCKey Key -> EnumMap GHCKey Key)
-> (TypeIndex, EnumMap GHCKey Key)
-> (TypeIndex, 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)
    go :: NameTree -> StateT (Int, EnumMap GHCKey Key) m (Forest Decl)
    go :: NameTree -> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
go (NameTree Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
nt) = [(String, (EnumSet GHCKey, DeclType, NameTree, Loc))]
-> ((String, (EnumSet GHCKey, DeclType, NameTree, Loc))
    -> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl))
-> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
-> [(String, (EnumSet GHCKey, DeclType, NameTree, Loc))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
nt) (((String, (EnumSet GHCKey, DeclType, NameTree, Loc))
  -> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl))
 -> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl))
-> ((String, (EnumSet GHCKey, DeclType, NameTree, Loc))
    -> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl))
-> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
forall a b. (a -> b) -> a -> b
$ \(String
name, (EnumSet GHCKey
ghckeys, DeclType
typ, NameTree
sub, Loc
mloc)) -> do
      Key
key <- StateT (TypeIndex, EnumMap GHCKey Key) m Key
fresh
      [GHCKey]
-> (GHCKey -> StateT (TypeIndex, EnumMap GHCKey Key) m ())
-> StateT (TypeIndex, EnumMap GHCKey Key) m ()
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 (TypeIndex, EnumMap GHCKey Key) m ()
assoc Key
key)
      Forest Decl
sub' <- NameTree -> StateT (TypeIndex, EnumMap GHCKey Key) m (Forest Decl)
go NameTree
sub
      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
exports) (EnumSet GHCKey -> [GHCKey]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
ghckeys)
      Tree Decl -> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree Decl -> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl))
-> Tree Decl
-> StateT (TypeIndex, EnumMap GHCKey Key) m (Tree Decl)
forall a b. (a -> b) -> a -> b
$ Decl -> Forest Decl -> Tree Decl
forall a. a -> Forest a -> Tree a
Tree.Node (String -> Key -> EnumSet GHCKey -> Bool -> DeclType -> Loc -> Decl
Decl String
name Key
key EnumSet GHCKey
ghckeys Bool
exported DeclType
typ Loc
mloc) Forest Decl
sub'

newtype NameTree = NameTree (Map String (EnumSet GHCKey, DeclType, NameTree, Loc))

instance Semigroup NameTree where
  NameTree Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
ta <> :: NameTree -> NameTree -> NameTree
<> NameTree Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
tb = Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree
NameTree (Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree)
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree
forall a b. (a -> b) -> a -> b
$ ((EnumSet GHCKey, DeclType, NameTree, Loc)
 -> (EnumSet GHCKey, DeclType, NameTree, Loc)
 -> (EnumSet GHCKey, DeclType, NameTree, Loc))
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (EnumSet GHCKey, DeclType, NameTree, Loc)
-> (EnumSet GHCKey, DeclType, NameTree, Loc)
-> (EnumSet GHCKey, DeclType, NameTree, Loc)
forall a c b d b d.
(Semigroup a, Semigroup c) =>
(a, b, c, d) -> (a, b, c, d) -> (a, b, c, d)
f Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
ta Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
tb
    where
      f :: (a, b, c, d) -> (a, b, c, d) -> (a, b, c, d)
f (a
ks, b
typ, c
sub, d
loc) (a
ks', b
_, c
sub', d
_) = (a
ks a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
ks', b
typ, c
sub c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
sub', d
loc)

instance Monoid NameTree where mempty :: NameTree
mempty = Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree
NameTree Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
forall a. Monoid a => a
mempty

deduplicate :: LexTree GHC.RealSrcLoc (DeclType, Name, Loc) -> NameTree
deduplicate :: LexTree RealSrcLoc (DeclType, Name, Loc) -> NameTree
deduplicate = NameTree
-> (NameTree
    -> RealSrcLoc
    -> (DeclType, Name, Loc)
    -> NameTree
    -> RealSrcLoc
    -> NameTree
    -> NameTree)
-> LexTree RealSrcLoc (DeclType, Name, Loc)
-> NameTree
forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
LT.foldLexTree NameTree
forall a. Monoid a => a
mempty ((NameTree
  -> RealSrcLoc
  -> (DeclType, Name, Loc)
  -> NameTree
  -> RealSrcLoc
  -> NameTree
  -> NameTree)
 -> LexTree RealSrcLoc (DeclType, Name, Loc) -> NameTree)
-> (NameTree
    -> RealSrcLoc
    -> (DeclType, Name, Loc)
    -> NameTree
    -> RealSrcLoc
    -> NameTree
    -> NameTree)
-> LexTree RealSrcLoc (DeclType, Name, Loc)
-> NameTree
forall a b. (a -> b) -> a -> b
$ \NameTree
l RealSrcLoc
_ (DeclType
typ, Name String
str EnumSet GHCKey
ks, Loc
mloc) NameTree
sub RealSrcLoc
_ NameTree
r ->
  let this :: NameTree
this = Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree
NameTree (Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree)
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc) -> NameTree
forall a b. (a -> b) -> a -> b
$ String
-> (EnumSet GHCKey, DeclType, NameTree, Loc)
-> Map String (EnumSet GHCKey, DeclType, NameTree, Loc)
forall k a. k -> a -> Map k a
Map.singleton String
str (EnumSet GHCKey
ks, DeclType
typ, NameTree
sub, Loc
mloc)
   in NameTree
l NameTree -> NameTree -> NameTree
forall a. Semigroup a => a -> a -> a
<> NameTree
this NameTree -> NameTree -> NameTree
forall a. Semigroup a => a -> a -> a
<> NameTree
r

structure :: [GHCDecl] -> Either ParseError (LexTree GHC.RealSrcLoc (DeclType, Name, Loc))
structure :: [GHCDecl]
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
structure =
  (LexTree RealSrcLoc (DeclType, Name, Loc)
 -> GHCDecl
 -> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc)))
-> LexTree RealSrcLoc (DeclType, Name, Loc)
-> [GHCDecl]
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\LexTree RealSrcLoc (DeclType, Name, Loc)
t (DeclType
ty, RealSrcSpan
sp, IfExtName
na, Loc
mloc) -> (TreeError RealSrcLoc (DeclType, Name, Loc) -> ParseError)
-> Either
     (TreeError RealSrcLoc (DeclType, Name, Loc))
     (LexTree RealSrcLoc (DeclType, Name, Loc))
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TreeError RealSrcLoc (DeclType, Name, Loc) -> ParseError
TreeError (Either
   (TreeError RealSrcLoc (DeclType, Name, Loc))
   (LexTree RealSrcLoc (DeclType, Name, Loc))
 -> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc)))
-> Either
     (TreeError RealSrcLoc (DeclType, Name, Loc))
     (LexTree RealSrcLoc (DeclType, Name, Loc))
-> Either ParseError (LexTree RealSrcLoc (DeclType, Name, Loc))
forall a b. (a -> b) -> a -> b
$ ((DeclType, Name, Loc)
 -> (DeclType, Name, Loc) -> Maybe (DeclType, Name, Loc))
-> RealSrcLoc
-> (DeclType, Name, Loc)
-> RealSrcLoc
-> LexTree RealSrcLoc (DeclType, Name, Loc)
-> Either
     (TreeError RealSrcLoc (DeclType, Name, Loc))
     (LexTree RealSrcLoc (DeclType, Name, Loc))
forall p a.
Ord p =>
(a -> a -> Maybe a)
-> p
-> a
-> p
-> LexTree p a
-> Either (TreeError p a) (LexTree p a)
LT.insertWith (DeclType, Name, Loc)
-> (DeclType, Name, Loc) -> Maybe (DeclType, Name, Loc)
forall a c c.
Eq a =>
(a, Name, c) -> (a, Name, c) -> Maybe (a, Name, c)
f (RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanStart RealSrcSpan
sp) (DeclType
ty, IfExtName -> Name
mkName IfExtName
na, Loc
mloc) (RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanEnd RealSrcSpan
sp) LexTree RealSrcLoc (DeclType, Name, Loc)
t)
    LexTree RealSrcLoc (DeclType, Name, Loc)
forall p a. LexTree p a
LT.emptyLexTree
  where
    f :: (a, Name, c) -> (a, Name, c) -> Maybe (a, Name, c)
f (a
ta, Name String
na EnumSet GHCKey
ka, c
mloc) (a
tb, Name String
nb EnumSet GHCKey
kb, c
_)
      | a
ta a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
tb Bool -> Bool -> Bool
&& String
na String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nb = (a, Name, c) -> Maybe (a, Name, c)
forall a. a -> Maybe a
Just (a
ta, String -> EnumSet GHCKey -> Name
Name String
na (EnumSet GHCKey
ka EnumSet GHCKey -> EnumSet GHCKey -> EnumSet GHCKey
forall a. Semigroup a => a -> a -> a
<> EnumSet GHCKey
kb), c
mloc)
      | Bool
otherwise = Maybe (a, Name, c)
forall a. Maybe a
Nothing

spanToLoc :: GHC.RealSrcSpan -> Loc
spanToLoc :: RealSrcSpan -> Loc
spanToLoc RealSrcSpan
spn = TypeIndex -> TypeIndex -> Loc
Loc (RealSrcSpan -> TypeIndex
GHC.srcSpanStartLine RealSrcSpan
spn) (RealSrcSpan -> TypeIndex
GHC.srcSpanStartCol RealSrcSpan
spn)

-- | 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 :: IfExtName -> Bool
isGenerated = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
'$' (String -> Bool) -> (IfExtName -> String) -> IfExtName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfExtName -> String
forall a. NamedThing a => a -> String
GHC.getOccString

collect :: GHC.HieFile -> Either ParseError Collect
collect :: HieFile -> Either ParseError Collect
collect (GHC.HieFile String
_ Module
_ Array TypeIndex HieTypeFlat
typeArr (GHC.HieASTs Map FastString (HieAST TypeIndex)
asts) [AvailInfo]
_ ByteString
_) = StateT Collect (Either ParseError) ()
-> Collect -> Either ParseError Collect
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Traversal
  (Map FastString (HieAST TypeIndex))
  (Map FastString Any)
  (HieAST TypeIndex)
  Any
-> Map FastString (HieAST TypeIndex)
-> (HieAST TypeIndex -> StateT Collect (Either ParseError) ())
-> StateT Collect (Either ParseError) ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ Traversal
  (Map FastString (HieAST TypeIndex))
  (Map FastString Any)
  (HieAST TypeIndex)
  Any
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Map FastString (HieAST TypeIndex)
asts HieAST TypeIndex -> StateT Collect (Either ParseError) ()
collect') ([GHCDecl]
-> [(RealSrcLoc, GHCKey)]
-> EnumMap GHCKey (EnumSet GHCKey)
-> Collect
Collect [GHCDecl]
forall a. Monoid a => a
mempty [(RealSrcLoc, GHCKey)]
forall a. Monoid a => a
mempty EnumMap GHCKey (EnumSet GHCKey)
forall a. Monoid a => a
mempty)
  where
    tellDecl :: GHCDecl -> StateT Collect (Either ParseError) ()
    tellDecl :: GHCDecl -> StateT Collect (Either ParseError) ()
tellDecl GHCDecl
decl = (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> StateT Collect (Either ParseError) ())
-> (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ \(Collect [GHCDecl]
decls [(RealSrcLoc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [GHCDecl]
-> [(RealSrcLoc, GHCKey)]
-> EnumMap GHCKey (EnumSet GHCKey)
-> Collect
Collect (GHCDecl
decl GHCDecl -> [GHCDecl] -> [GHCDecl]
forall a. a -> [a] -> [a]
: [GHCDecl]
decls) [(RealSrcLoc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types

    tellUse :: GHC.RealSrcLoc -> GHCKey -> StateT Collect (Either ParseError) ()
    tellUse :: RealSrcLoc -> GHCKey -> StateT Collect (Either ParseError) ()
tellUse RealSrcLoc
loc GHCKey
key = (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> StateT Collect (Either ParseError) ())
-> (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ \(Collect [GHCDecl]
decls [(RealSrcLoc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [GHCDecl]
-> [(RealSrcLoc, GHCKey)]
-> EnumMap GHCKey (EnumSet GHCKey)
-> Collect
Collect [GHCDecl]
decls ((RealSrcLoc
loc, GHCKey
key) (RealSrcLoc, GHCKey)
-> [(RealSrcLoc, GHCKey)] -> [(RealSrcLoc, GHCKey)]
forall a. a -> [a] -> [a]
: [(RealSrcLoc, GHCKey)]
uses) EnumMap GHCKey (EnumSet GHCKey)
types

    tellType :: GHC.Name -> GHC.TypeIndex -> StateT Collect (Either ParseError) ()
    tellType :: IfExtName -> TypeIndex -> StateT Collect (Either ParseError) ()
tellType IfExtName
name TypeIndex
ix = (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Collect -> Collect) -> StateT Collect (Either ParseError) ())
-> (Collect -> Collect) -> StateT Collect (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ \(Collect [GHCDecl]
decls [(RealSrcLoc, GHCKey)]
uses EnumMap GHCKey (EnumSet GHCKey)
types) -> [GHCDecl]
-> [(RealSrcLoc, GHCKey)]
-> EnumMap GHCKey (EnumSet GHCKey)
-> Collect
Collect [GHCDecl]
decls [(RealSrcLoc, 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
(<>) (IfExtName -> GHCKey
ghcNameKey IfExtName
name) (EnumMap TypeIndex (EnumSet GHCKey)
typeMap EnumMap TypeIndex (EnumSet GHCKey) -> TypeIndex -> EnumSet GHCKey
forall k a. Enum k => EnumMap k a -> k -> a
EnumMap.! TypeIndex
ix) EnumMap GHCKey (EnumSet GHCKey)
types)

    typeMap :: EnumMap TypeIndex (EnumSet GHCKey)
typeMap = Array TypeIndex HieTypeFlat -> EnumMap TypeIndex (EnumSet GHCKey)
resolveTypes Array TypeIndex HieTypeFlat
typeArr

    collect' :: GHC.HieAST GHC.TypeIndex -> StateT Collect (Either ParseError) ()
    collect' :: HieAST TypeIndex -> StateT Collect (Either ParseError) ()
collect' node :: HieAST TypeIndex
node@(GHC.Node NodeInfo TypeIndex
_ RealSrcSpan
_ [HieAST TypeIndex]
children) =
      Traversal
  (HieAST TypeIndex)
  (HieAST TypeIndex)
  (NodeInfo TypeIndex)
  (NodeInfo TypeIndex)
-> HieAST TypeIndex
-> (NodeInfo TypeIndex -> StateT Collect (Either ParseError) ())
-> StateT Collect (Either ParseError) ()
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 TypeIndex)
  (HieAST TypeIndex)
  (NodeInfo TypeIndex)
  (NodeInfo TypeIndex)
sourceInfo HieAST TypeIndex
node ((NodeInfo TypeIndex -> StateT Collect (Either ParseError) ())
 -> StateT Collect (Either ParseError) ())
-> (NodeInfo TypeIndex -> StateT Collect (Either ParseError) ())
-> StateT Collect (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ \NodeInfo TypeIndex
nodeInfo ->
        if ((NodeInfo TypeIndex -> Bool) -> Bool)
-> [NodeInfo TypeIndex -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NodeInfo TypeIndex -> Bool) -> NodeInfo TypeIndex -> Bool
forall a b. (a -> b) -> a -> b
$ NodeInfo TypeIndex
nodeInfo) [NodeInfo TypeIndex -> Bool
forall a. NodeInfo a -> Bool
isInstanceNode, NodeInfo TypeIndex -> Bool
forall a. NodeInfo a -> Bool
isTypeSignatureNode, NodeInfo TypeIndex -> Bool
forall a. NodeInfo a -> Bool
isInlineNode, NodeInfo TypeIndex -> Bool
forall a. NodeInfo a -> Bool
isMinimalNode, NodeInfo TypeIndex -> Bool
forall a. NodeInfo a -> Bool
isDerivingNode]
          then () -> StateT Collect (Either ParseError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else do
            [(Identifier, IdentifierDetails TypeIndex)]
-> ((Identifier, IdentifierDetails TypeIndex)
    -> StateT Collect (Either ParseError) ())
-> StateT Collect (Either ParseError) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Identifier (IdentifierDetails TypeIndex)
-> [(Identifier, IdentifierDetails TypeIndex)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Identifier (IdentifierDetails TypeIndex)
 -> [(Identifier, IdentifierDetails TypeIndex)])
-> Map Identifier (IdentifierDetails TypeIndex)
-> [(Identifier, IdentifierDetails TypeIndex)]
forall a b. (a -> b) -> a -> b
$ NodeInfo TypeIndex -> Map Identifier (IdentifierDetails TypeIndex)
forall a. NodeInfo a -> NodeIdentifiers a
GHC.nodeIdentifiers NodeInfo TypeIndex
nodeInfo) (((Identifier, IdentifierDetails TypeIndex)
  -> StateT Collect (Either ParseError) ())
 -> StateT Collect (Either ParseError) ())
-> ((Identifier, IdentifierDetails TypeIndex)
    -> StateT Collect (Either ParseError) ())
-> StateT Collect (Either ParseError) ()
forall a b. (a -> b) -> a -> b
$ \case
              (Right IfExtName
name, GHC.IdentifierDetails Maybe TypeIndex
ty Set ContextInfo
info)
                | Bool -> Bool
not (IfExtName -> Bool
isGenerated IfExtName
name) -> do
                    (TypeIndex -> StateT Collect (Either ParseError) ())
-> Maybe TypeIndex -> StateT Collect (Either ParseError) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IfExtName -> TypeIndex -> StateT Collect (Either ParseError) ()
tellType IfExtName
name) Maybe TypeIndex
ty
                    case Set ContextInfo -> IdentifierType
classifyIdentifier Set ContextInfo
info of
                      IdentifierType
IdnIgnore -> () -> StateT Collect (Either ParseError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      IdentifierType
IdnUse -> RealSrcLoc -> GHCKey -> StateT Collect (Either ParseError) ()
tellUse (RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanStart (RealSrcSpan -> RealSrcLoc) -> RealSrcSpan -> RealSrcLoc
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
GHC.nodeSpan HieAST TypeIndex
node) (IfExtName -> GHCKey
ghcNameKey IfExtName
name)
                      IdnDecl DeclType
typ RealSrcSpan
sp
                        | RealSrcSpan -> Bool
GHC.isPointSpan RealSrcSpan
sp -> () -> StateT Collect (Either ParseError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        | Bool
otherwise -> GHCDecl -> StateT Collect (Either ParseError) ()
tellDecl (DeclType
typ, RealSrcSpan
sp, IfExtName
name, RealSrcSpan -> Loc
spanToLoc RealSrcSpan
sp)
              (Identifier, IdentifierDetails TypeIndex)
_ -> () -> StateT Collect (Either ParseError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            (HieAST TypeIndex -> StateT Collect (Either ParseError) ())
-> [HieAST TypeIndex] -> StateT Collect (Either ParseError) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HieAST TypeIndex -> StateT Collect (Either ParseError) ()
collect' [HieAST TypeIndex]
children

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
spanSpans 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