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 -> String
(Int -> ModuleElem -> ShowS)
-> (ModuleElem -> String)
-> ([ModuleElem] -> ShowS)
-> Show ModuleElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleElem] -> ShowS
$cshowList :: [ModuleElem] -> ShowS
show :: ModuleElem -> String
$cshow :: ModuleElem -> String
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 -> String
name (Fun f :: String
f)     = String
f
name (Class c :: String
c _) = String
c
name (Data d :: String
d _)  = String
d

children :: ModuleElem -> [Id]
children :: ModuleElem -> [String]
children (Fun   _)     = []
children (Class _ ms :: [String]
ms)  = [String]
ms
children (Data  _ dcs :: [String]
dcs) = [String]
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 :: String -> m [ModuleElem]
getModuleExports mn :: String
mn =
    do Module
module_  <- String -> m Module
forall (m :: * -> *). MonadInterpreter m => String -> m Module
findModule String
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 df :: DynFlags
df xs :: [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 ((String -> ModuleElem) -> [String] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map String -> ModuleElem
Fun ([String] -> [ModuleElem])
-> (ModuleElem -> [String]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [String]
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 ((String -> ModuleElem) -> [String] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map String -> ModuleElem
Fun ([String] -> [ModuleElem])
-> (ModuleElem -> [String]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [String]
children) [ModuleElem]
cs
                      ]
    where cs :: [ModuleElem]
cs = [String -> [String] -> ModuleElem
Class (DynFlags -> TyCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df TyCon
tc) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> String -> Bool
alsoIn [ModuleElem]
fs) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df (Id -> String) -> [Id] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class -> [Id]
GHC.classMethods Class
c)
               | GHC.ATyCon tc :: TyCon
tc <- [TyThing]
xs, Just c :: Class
c  <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ts :: [ModuleElem]
ts = [String -> [String] -> ModuleElem
Data  (DynFlags -> TyCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df TyCon
tc) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> String -> Bool
alsoIn [ModuleElem]
ds) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df (DataCon -> String) -> [DataCon] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> [DataCon]
GHC.tyConDataCons TyCon
tc)
               | GHC.ATyCon tc :: TyCon
tc <- [TyThing]
xs, Maybe Class
Nothing <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ds :: [ModuleElem]
ds = [String -> ModuleElem
Fun (String -> ModuleElem) -> String -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df DataCon
dc | GHC.AConLike (GHC.RealDataCon dc :: DataCon
dc) <- [TyThing]
xs]
          fs :: [ModuleElem]
fs = [String -> ModuleElem
Fun (String -> ModuleElem) -> String -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df Id
f  | GHC.AnId f :: Id
f                        <- [TyThing]
xs]
          alsoIn :: [ModuleElem] -> String -> Bool
alsoIn es :: [ModuleElem]
es = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ModuleElem -> String) -> [ModuleElem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleElem -> String
name [ModuleElem]
es)

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