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]
(Int -> ReadS ModuleElem)
-> ReadS [ModuleElem]
-> ReadPrec ModuleElem
-> ReadPrec [ModuleElem]
-> Read 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
(Int -> ModuleElem -> ShowS)
-> (ModuleElem -> Id) -> ([ModuleElem] -> ShowS) -> Show ModuleElem
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
(ModuleElem -> ModuleElem -> Bool)
-> (ModuleElem -> ModuleElem -> Bool) -> Eq ModuleElem
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_  <- Id -> m Module
forall (m :: * -> *). MonadInterpreter m => Id -> m Module
findModule Id
mn
       ModuleInfo
mod_info <- m (Maybe ModuleInfo) -> m ModuleInfo
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (m (Maybe ModuleInfo) -> m ModuleInfo)
-> m (Maybe ModuleInfo) -> m ModuleInfo
forall a b. (a -> b) -> a -> b
$ RunGhc1 m Module (Maybe ModuleInfo)
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall {n :: * -> *}.
(MonadIO n, MonadMask n) =>
Module -> GhcT n (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
module_
       [Maybe TyThing]
exports  <- (Name -> m (Maybe TyThing)) -> [Name] -> m [Maybe TyThing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RunGhc1 m Name (Maybe TyThing)
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall {n :: * -> *}.
(MonadIO n, MonadMask n) =>
Name -> GhcT n (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName) (ModuleInfo -> [Name]
GHC.modInfoExports ModuleInfo
mod_info)
       DynFlags
dflags   <- RunGhc m DynFlags
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall {n :: * -> *}. (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
       --
       [ModuleElem] -> m [ModuleElem]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleElem] -> m [ModuleElem]) -> [ModuleElem] -> m [ModuleElem]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
dflags ([Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TyThing]
exports)

asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem]
asModElemList :: DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
df [TyThing]
xs = [[ModuleElem]] -> [ModuleElem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                        [ModuleElem]
cs,
                        [ModuleElem]
ts,
                        [ModuleElem]
ds [ModuleElem] -> [ModuleElem] -> [ModuleElem]
forall a. Eq a => [a] -> [a] -> [a]
\\ (ModuleElem -> [ModuleElem]) -> [ModuleElem] -> [ModuleElem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Id -> ModuleElem) -> [Id] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map Id -> ModuleElem
Fun ([Id] -> [ModuleElem])
-> (ModuleElem -> [Id]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [Id]
children) [ModuleElem]
ts,
                        [ModuleElem]
fs [ModuleElem] -> [ModuleElem] -> [ModuleElem]
forall a. Eq a => [a] -> [a] -> [a]
\\ (ModuleElem -> [ModuleElem]) -> [ModuleElem] -> [ModuleElem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Id -> ModuleElem) -> [Id] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map Id -> ModuleElem
Fun ([Id] -> [ModuleElem])
-> (ModuleElem -> [Id]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [Id]
children) [ModuleElem]
cs
                      ]
    where cs :: [ModuleElem]
cs = [Id -> [Id] -> ModuleElem
Class (DynFlags -> TyCon -> Id
forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df TyCon
tc) ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> Id -> Bool
alsoIn [ModuleElem]
fs) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> Id
forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df (Id -> Id) -> [Id] -> [Id]
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  (DynFlags -> TyCon -> Id
forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df TyCon
tc) ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> Id -> Bool
alsoIn [ModuleElem]
ds) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> Id
forall a. NamedThing a => DynFlags -> a -> Id
getUnqualName DynFlags
df (DataCon -> Id) -> [DataCon] -> [Id]
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 (Id -> ModuleElem) -> Id -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> Id
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 (Id -> ModuleElem) -> Id -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> Id
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 = (Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ModuleElem -> Id) -> [ModuleElem] -> [Id]
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.showSDocUnqual DynFlags
dfs (SDoc -> Id) -> (a -> SDoc) -> a -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. NamedThing a => a -> SDoc
GHC.pprParenSymName