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

import GHC (Fixity, Ghc, TyCon, TyThing, Type)
import qualified GHC as G
import GHC.Core.ConLike (ConLike (..))
import GHC.Core.DataCon (dataConNonlinearType)
import GHC.Core.FamInstEnv (pprFamInsts)
import qualified GHC.Core.InstEnv as InstEnv
import GHC.Core.PatSyn (PatSyn)
import GHC.Types.Name.Set (elemNameSet, mkNameSet)
import GHC.Types.Var (varType)
import GHC.Utils.Outputable as Outputable

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

import Hhp.Gap

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

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

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

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

infoThing :: String -> Ghc SDoc
infoThing :: String -> Ghc SDoc
infoThing String
str = do
    NonEmpty Name
names <- String -> Ghc (NonEmpty Name)
forall (m :: * -> *). GhcMonad m => String -> m (NonEmpty Name)
G.parseName String
str
    NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
mb_stuffs <- (Name -> Ghc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> NonEmpty Name
-> Ghc
     (NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Bool
-> Name
-> Ghc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
G.getInfo Bool
False) NonEmpty 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)]
 -> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)])
-> [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. NonEmpty a -> [a]
fromNE NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
mb_stuffs
    SDoc -> Ghc SDoc
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Ghc SDoc) -> SDoc -> Ghc SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
forall doc. IsLine doc => String -> doc
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)
  where
    getTyThing :: (a, b, c, d, e) -> a
getTyThing (a
t, b
_, c
_, d
_, e
_) = a
t
    fixInfo :: (a, b, c, d, e) -> (a, b, c, d)
fixInfo (a
t, b
f, c
cs, d
fs, e
_) = (a
t, b
f, c
cs, d
fs)

filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren :: forall a. (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
G.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
G.getName TyThing
t | a
x <- [a]
xs, TyThing
t <- TyThing -> [TyThing]
implicitTyThings (a -> TyThing
get_thing a
x)]

pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [G.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
forall doc. IsDoc doc => doc -> doc -> doc
$$ Fixity -> SDoc
show_fixity Fixity
fixity
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [ClsInst] -> SDoc
InstEnv.pprInstances [ClsInst]
insts
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [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
G.defaultFixity = SDoc
forall doc. IsOutput doc => doc
Outputable.empty
        | Bool
otherwise = Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
fx SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyThing -> Name
forall a. NamedThing a => a -> Name
G.getName TyThing
thing)