module Hint.Reflection (
      ModuleElem(..), Id, name, children,
      getModuleExports,
) where

import Data.List
import Data.Maybe

import Hint.Base
import qualified Hint.GHC as GHC

-- | An Id for a class, a type constructor, a data constructor, a binding, etc
type Id = String

data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id]
  deriving (ReadPrec [ModuleElem]
ReadPrec ModuleElem
Int -> ReadS ModuleElem
ReadS [ModuleElem]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ModuleElem]
$creadListPrec :: ReadPrec [ModuleElem]
readPrec :: ReadPrec ModuleElem
$creadPrec :: ReadPrec ModuleElem
readList :: ReadS [ModuleElem]
$creadList :: ReadS [ModuleElem]
readsPrec :: Int -> ReadS ModuleElem
$creadsPrec :: Int -> ReadS ModuleElem
Read, Int -> ModuleElem -> ShowS
[ModuleElem] -> ShowS
ModuleElem -> Id
forall a.
(Int -> a -> ShowS) -> (a -> Id) -> ([a] -> ShowS) -> Show a
showList :: [ModuleElem] -> ShowS
$cshowList :: [ModuleElem] -> ShowS
show :: ModuleElem -> Id
$cshow :: ModuleElem -> Id
showsPrec :: Int -> ModuleElem -> ShowS
$cshowsPrec :: Int -> ModuleElem -> ShowS
Show, ModuleElem -> ModuleElem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleElem -> ModuleElem -> Bool
$c/= :: ModuleElem -> ModuleElem -> Bool
== :: ModuleElem -> ModuleElem -> Bool
$c== :: ModuleElem -> ModuleElem -> Bool
Eq)

name :: ModuleElem -> Id
name :: ModuleElem -> Id
name (Fun Id
f)     = Id
f
name (Class Id
c [Id]
_) = Id
c
name (Data Id
d [Id]
_)  = Id
d

children :: ModuleElem -> [Id]
children :: ModuleElem -> [Id]
children (Fun   Id
_)     = []
children (Class Id
_ [Id]
ms)  = [Id]
ms
children (Data  Id
_ [Id]
dcs) = [Id]
dcs

-- | Gets an abstract representation of all the entities exported by the module.
--   It is similar to the @:browse@ command in GHCi.
getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem]
getModuleExports :: forall (m :: * -> *). MonadInterpreter m => Id -> m [ModuleElem]
getModuleExports Id
mn =
    do Module
module_  <- forall (m :: * -> *). MonadInterpreter m => Id -> m Module
findModule Id
mn
       ModuleInfo
mod_info <- forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
module_
       [Maybe TyThing]
exports  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Name
n -> forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName Name
n) (ModuleInfo -> [Name]
GHC.modInfoExports ModuleInfo
mod_info)
       DynFlags
dflags   <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
       --
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
dflags (forall a. [Maybe a] -> [a]
catMaybes [Maybe TyThing]
exports)

asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem]
asModElemList :: DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
df [TyThing]
xs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                        [ModuleElem]
cs,
                        [ModuleElem]
ts,
                        [ModuleElem]
ds forall a. Eq a => [a] -> [a] -> [a]
\\ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map Id -> ModuleElem
Fun forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [Id]
children) [ModuleElem]
ts,
                        [ModuleElem]
fs forall a. Eq a => [a] -> [a] -> [a]
\\ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map Id -> ModuleElem
Fun forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [Id]
children) [ModuleElem]
cs
                      ]
    where cs :: [ModuleElem]
cs = [Id -> [Id] -> ModuleElem
Class (forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df TyCon
tc) (forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> Id -> Bool
alsoIn [ModuleElem]
fs) forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class -> [Id]
GHC.classMethods Class
c)
               | GHC.ATyCon TyCon
tc <- [TyThing]
xs, Just Class
c  <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ts :: [ModuleElem]
ts = [Id -> [Id] -> ModuleElem
Data  (forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df TyCon
tc) (forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> Id -> Bool
alsoIn [ModuleElem]
ds) forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> [DataCon]
GHC.tyConDataCons TyCon
tc)
               | GHC.ATyCon TyCon
tc <- [TyThing]
xs, Maybe Class
Nothing <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ds :: [ModuleElem]
ds = [Id -> ModuleElem
Fun forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df DataCon
dc | GHC.AConLike (GHC.RealDataCon DataCon
dc) <- [TyThing]
xs]
          fs :: [ModuleElem]
fs = [Id -> ModuleElem
Fun forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df Id
f  | GHC.AnId Id
f                        <- [TyThing]
xs]
          alsoIn :: [ModuleElem] -> Id -> Bool
alsoIn [ModuleElem]
es = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map ModuleElem -> Id
name [ModuleElem]
es)

getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String
getUnqualName :: forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
dfs = DynFlags -> SDoc -> Id
GHC.showSDoc DynFlags
dfs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> SDoc
GHC.pprParenSymName