{-# LANGUAGE BangPatterns #-}

module Hhp.Find (
    Symbol
  , SymMdlDb
  , findSymbol
  , getSymMdlDb
  , lookupSym
  ) where

import GHC (Ghc, DynFlags, Module, ModuleInfo)
import qualified GHC as G
import Module (Module(..))
import Outputable (ppr)
import PackageConfig (PackageConfig, exposedModules, packageConfigId)
import Packages (listPackageConfigMap)

import Control.DeepSeq (force)
import Data.Function (on)
import Data.List (groupBy, sort)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)

import Hhp.Doc (showOneLine, styleUnqualified)
import Hhp.GHCApi
import Hhp.Gap (getModuleName)
import Hhp.Types

-- | Type of key for `SymMdlDb`.
type Symbol = String
-- | Database from 'Symbol' to modules.
newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])

-- | Finding modules to which the symbol belong.
findSymbol :: Options -> Cradle -> Symbol -> IO String
findSymbol :: Options -> Cradle -> Symbol -> IO Symbol
findSymbol Options
opt Cradle
cradle Symbol
sym = Ghc Symbol -> IO Symbol
forall a. Ghc a -> IO a
withGHC' (Ghc Symbol -> IO Symbol) -> Ghc Symbol -> IO Symbol
forall a b. (a -> b) -> a -> b
$ do
    Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
    Options -> Symbol -> SymMdlDb -> Symbol
lookupSym Options
opt Symbol
sym (SymMdlDb -> Symbol) -> Ghc SymMdlDb -> Ghc Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc SymMdlDb
getSymMdlDb

-- | Creating 'SymMdlDb'.
getSymMdlDb :: Ghc SymMdlDb
getSymMdlDb :: Ghc SymMdlDb
getSymMdlDb = do
    [(Symbol, Symbol)]
sm <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags Ghc DynFlags
-> (DynFlags -> Ghc [(Symbol, Symbol)]) -> Ghc [(Symbol, Symbol)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> Ghc [(Symbol, Symbol)]
browseAll
    let !sms :: [(Symbol, [Symbol])]
sms = [(Symbol, [Symbol])] -> [(Symbol, [Symbol])]
forall a. NFData a => a -> a
force ([(Symbol, [Symbol])] -> [(Symbol, [Symbol])])
-> [(Symbol, [Symbol])] -> [(Symbol, [Symbol])]
forall a b. (a -> b) -> a -> b
$ ([(Symbol, Symbol)] -> (Symbol, [Symbol]))
-> [[(Symbol, Symbol)]] -> [(Symbol, [Symbol])]
forall a b. (a -> b) -> [a] -> [b]
map [(Symbol, Symbol)] -> (Symbol, [Symbol])
forall a b. [(a, b)] -> (a, [b])
tieup ([[(Symbol, Symbol)]] -> [(Symbol, [Symbol])])
-> [[(Symbol, Symbol)]] -> [(Symbol, [Symbol])]
forall a b. (a -> b) -> a -> b
$ ((Symbol, Symbol) -> (Symbol, Symbol) -> Bool)
-> [(Symbol, Symbol)] -> [[(Symbol, Symbol)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Symbol -> Symbol -> Bool)
-> ((Symbol, Symbol) -> Symbol)
-> (Symbol, Symbol)
-> (Symbol, Symbol)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Symbol, Symbol) -> Symbol
forall a b. (a, b) -> a
fst) ([(Symbol, Symbol)] -> [[(Symbol, Symbol)]])
-> [(Symbol, Symbol)] -> [[(Symbol, Symbol)]]
forall a b. (a -> b) -> a -> b
$ [(Symbol, Symbol)] -> [(Symbol, Symbol)]
forall a. Ord a => [a] -> [a]
sort [(Symbol, Symbol)]
sm
        !m :: Map Symbol [Symbol]
m = Map Symbol [Symbol] -> Map Symbol [Symbol]
forall a. NFData a => a -> a
force (Map Symbol [Symbol] -> Map Symbol [Symbol])
-> Map Symbol [Symbol] -> Map Symbol [Symbol]
forall a b. (a -> b) -> a -> b
$ [(Symbol, [Symbol])] -> Map Symbol [Symbol]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Symbol, [Symbol])]
sms
    SymMdlDb -> Ghc SymMdlDb
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Symbol [Symbol] -> SymMdlDb
SymMdlDb Map Symbol [Symbol]
m)
  where
    tieup :: [(a, b)] -> (a, [b])
tieup [(a, b)]
x = ([a] -> a
forall a. [a] -> a
head (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
x), ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
x)

-- | Looking up 'SymMdlDb' with 'Symbol' to find modules.
lookupSym :: Options -> Symbol -> SymMdlDb -> String
lookupSym :: Options -> Symbol -> SymMdlDb -> Symbol
lookupSym Options
opt Symbol
sym (SymMdlDb Map Symbol [Symbol]
db) = Options -> [Symbol] -> Symbol
forall a. ToString a => Options -> a -> Symbol
convert Options
opt ([Symbol] -> Symbol) -> [Symbol] -> Symbol
forall a b. (a -> b) -> a -> b
$ [Symbol] -> Maybe [Symbol] -> [Symbol]
forall a. a -> Maybe a -> a
fromMaybe [] (Symbol -> Map Symbol [Symbol] -> Maybe [Symbol]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Symbol
sym Map Symbol [Symbol]
db)

----------------------------------------------------------------

-- | Browsing all functions in all system/user modules.
browseAll :: DynFlags -> Ghc [(String,String)]
browseAll :: DynFlags -> Ghc [(Symbol, Symbol)]
browseAll DynFlags
dflag = do
    let ms :: [Module]
ms = DynFlags -> [Module]
packageModules DynFlags
dflag
    [Maybe ModuleInfo]
is <- (Module -> Ghc (Maybe ModuleInfo))
-> [Module] -> Ghc [Maybe ModuleInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo [Module]
ms
    [(Symbol, Symbol)] -> Ghc [(Symbol, Symbol)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Symbol, Symbol)] -> Ghc [(Symbol, Symbol)])
-> [(Symbol, Symbol)] -> Ghc [(Symbol, Symbol)]
forall a b. (a -> b) -> a -> b
$ ((Module, Maybe ModuleInfo) -> [(Symbol, Symbol)])
-> [(Module, Maybe ModuleInfo)] -> [(Symbol, Symbol)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> (Module, Maybe ModuleInfo) -> [(Symbol, Symbol)]
toNameModule DynFlags
dflag) ([Module] -> [Maybe ModuleInfo] -> [(Module, Maybe ModuleInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Module]
ms [Maybe ModuleInfo]
is)

toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]
toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(Symbol, Symbol)]
toNameModule DynFlags
_     (Module
_,Maybe ModuleInfo
Nothing)  = []
toNameModule DynFlags
dflag (Module
m,Just ModuleInfo
inf) = (Name -> (Symbol, Symbol)) -> [Name] -> [(Symbol, Symbol)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> (Name -> Symbol
toStr Name
name, Symbol
mdl)) [Name]
names
  where
    mdl :: Symbol
mdl = ModuleName -> Symbol
G.moduleNameString (Module -> ModuleName
G.moduleName Module
m)
    names :: [Name]
names = ModuleInfo -> [Name]
G.modInfoExports ModuleInfo
inf
    toStr :: Name -> Symbol
toStr = DynFlags -> PprStyle -> SDoc -> Symbol
showOneLine DynFlags
dflag (DynFlags -> PprStyle
styleUnqualified DynFlags
dflag) (SDoc -> Symbol) -> (Name -> SDoc) -> Name -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr

packageModules :: DynFlags -> [Module]
packageModules :: DynFlags -> [Module]
packageModules DynFlags
dflag = (PackageConfig -> [Module]) -> [PackageConfig] -> [Module]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageConfig -> [Module]
fromPackageConfig ([PackageConfig] -> [Module]) -> [PackageConfig] -> [Module]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [PackageConfig]
listPackageConfigMap DynFlags
dflag

fromPackageConfig :: PackageConfig -> [Module]
fromPackageConfig :: PackageConfig -> [Module]
fromPackageConfig PackageConfig
pkgcnf = [Module]
modules
  where
    uid :: UnitId
uid = PackageConfig -> UnitId
packageConfigId PackageConfig
pkgcnf -- check me
    moduleNames :: [ModuleName]
moduleNames = ((ModuleName, Maybe Module) -> ModuleName)
-> [(ModuleName, Maybe Module)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Maybe Module) -> ModuleName
forall a b. (a, b) -> a
getModuleName ([(ModuleName, Maybe Module)] -> [ModuleName])
-> [(ModuleName, Maybe Module)] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
pkgcnf
    modules :: [Module]
modules = (ModuleName -> Module) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> ModuleName -> Module
Module UnitId
uid) [ModuleName]
moduleNames