module Hhp.Things (
    GapThing(..)
  , fromTyThing
  , infoThing
  ) where

import ConLike (ConLike(..))
import FamInstEnv
import GHC
import HscTypes
import qualified InstEnv
import NameSet
import Outputable
import PatSyn
import PprTyThing
import Var (varType)

import Data.List (intersperse)
import Data.Maybe (catMaybes)

import Hhp.Gap (getTyThing, fixInfo)

-- from ghc/InteractiveUI.hs

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

data GapThing = GtA Type
              | GtT TyCon
              | GtN
              | GtPatSyn PatSyn

fromTyThing :: TyThing -> GapThing
fromTyThing :: TyThing -> GapThing
fromTyThing (AnId Id
i)                   = Type -> GapThing
GtA (Type -> GapThing) -> Type -> GapThing
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
i
fromTyThing (AConLike (RealDataCon DataCon
d)) = Type -> GapThing
GtA (Type -> GapThing) -> Type -> GapThing
forall a b. (a -> b) -> a -> b
$ DataCon -> Type
dataConUserType DataCon
d
fromTyThing (AConLike (PatSynCon PatSyn
p))   = PatSyn -> GapThing
GtPatSyn PatSyn
p
fromTyThing (ATyCon TyCon
t)                 = TyCon -> GapThing
GtT TyCon
t
fromTyThing TyThing
_                          = GapThing
GtN

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

infoThing :: String -> Ghc SDoc
infoThing :: String -> Ghc SDoc
infoThing String
str = do
    [Name]
names <- String -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
str
    [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
mb_stuffs <- (Name -> Ghc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> [Name]
-> Ghc [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> Name
-> Ghc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo Bool
False) [Name]
names
    let filtered :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filtered = ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> TyThing)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> TyThing
forall a b c d e. (a, b, c, d, e) -> a
getTyThing ([(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
 -> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)])
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a b. (a -> b) -> a -> b
$ [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
mb_stuffs
    SDoc -> Ghc SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Ghc SDoc) -> SDoc -> Ghc SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
text String
"") ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((TyThing, Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo ((TyThing, Fixity, [ClsInst], [FamInst]) -> SDoc)
-> ((TyThing, Fixity, [ClsInst], [FamInst], SDoc)
    -> (TyThing, Fixity, [ClsInst], [FamInst]))
-> (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> (TyThing, Fixity, [ClsInst], [FamInst])
forall a b c d e. (a, b, c, d, e) -> (a, b, c, d)
fixInfo) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filtered)

filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren a -> TyThing
get_thing [a]
xs
    = [a
x | a
x <- [a]
xs, Bool -> Bool
not (TyThing -> Name
forall a. NamedThing a => a -> Name
getName (a -> TyThing
get_thing a
x) Name -> NameSet -> Bool
`elemNameSet` NameSet
implicits)]
  where
    implicits :: NameSet
implicits = [Name] -> NameSet
mkNameSet [TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
t | a
x <- [a]
xs, TyThing
t <- TyThing -> [TyThing]
implicitTyThings (a -> TyThing
get_thing a
x)]

pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc
pprInfo :: (TyThing, Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo (TyThing
thing, Fixity
fixity, [ClsInst]
insts, [FamInst]
famInsts)
    = TyThing -> SDoc
pprTyThingInContextLoc TyThing
thing
   SDoc -> SDoc -> SDoc
$$ Fixity -> SDoc
show_fixity Fixity
fixity
   SDoc -> SDoc -> SDoc
$$ [ClsInst] -> SDoc
InstEnv.pprInstances [ClsInst]
insts
   SDoc -> SDoc -> SDoc
$$ [FamInst] -> SDoc
pprFamInsts [FamInst]
famInsts
  where
    show_fixity :: Fixity -> SDoc
show_fixity Fixity
fx
      | Fixity
fx Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
defaultFixity = SDoc
Outputable.empty
      | Bool
otherwise           = Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
fx SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing)