module Hhp.Browse (
browseModule
, browse
) where
import Exception (ghandle)
import FastString (mkFastString)
import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
import qualified GHC as G
import Name (getOccString)
import Outputable (ppr, Outputable)
import TyCon (isAlgTyCon)
import Type (dropForAlls, splitFunTy_maybe, isPredTy)
import Control.Exception (SomeException(..))
import Data.Char (isAlpha)
import Data.List (sort)
import Data.Maybe (catMaybes)
import Hhp.Doc (showPage, styleUnqualified)
import Hhp.Gap
import Hhp.GHCApi
import Hhp.Things
import Hhp.Types
browseModule :: Options
-> Cradle
-> ModuleString
-> IO String
browseModule :: Options -> Cradle -> ModuleString -> IO ModuleString
browseModule Options
opt Cradle
cradle ModuleString
pkgmdl = Ghc ModuleString -> IO ModuleString
forall a. Ghc a -> IO a
withGHC' (Ghc ModuleString -> IO ModuleString)
-> Ghc ModuleString -> IO ModuleString
forall a b. (a -> b) -> a -> b
$ do
Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
Options -> ModuleString -> Ghc ModuleString
browse Options
opt ModuleString
pkgmdl
browse :: Options
-> ModuleString
-> Ghc String
browse :: Options -> ModuleString -> Ghc ModuleString
browse Options
opt ModuleString
pkgmdl = do
Options -> [ModuleString] -> ModuleString
forall a. ToString a => Options -> a -> ModuleString
convert Options
opt ([ModuleString] -> ModuleString)
-> ([ModuleString] -> [ModuleString])
-> [ModuleString]
-> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleString] -> [ModuleString]
forall a. Ord a => [a] -> [a]
sort ([ModuleString] -> ModuleString)
-> Ghc [ModuleString] -> Ghc ModuleString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ghc (Maybe ModuleInfo)
getModule Ghc (Maybe ModuleInfo)
-> (Maybe ModuleInfo -> Ghc [ModuleString]) -> Ghc [ModuleString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ModuleInfo -> Ghc [ModuleString]
listExports)
where
(Maybe ModuleString
mpkg,ModuleString
mdl) = ModuleString -> (Maybe ModuleString, ModuleString)
splitPkgMdl ModuleString
pkgmdl
mdlname :: ModuleName
mdlname = ModuleString -> ModuleName
G.mkModuleName ModuleString
mdl
mpkgid :: Maybe FastString
mpkgid = ModuleString -> FastString
mkFastString (ModuleString -> FastString)
-> Maybe ModuleString -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleString
mpkg
listExports :: Maybe ModuleInfo -> Ghc [ModuleString]
listExports Maybe ModuleInfo
Nothing = [ModuleString] -> Ghc [ModuleString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
listExports (Just ModuleInfo
mdinfo) = Options -> ModuleInfo -> Ghc [ModuleString]
processExports Options
opt ModuleInfo
mdinfo
getModule :: Ghc (Maybe ModuleInfo)
getModule = Ghc (Maybe ModuleInfo)
browsePackageModule Ghc (Maybe ModuleInfo)
-> (GhcException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`G.gcatch` GhcException -> Ghc (Maybe ModuleInfo)
fallback Ghc (Maybe ModuleInfo)
-> (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`G.gcatch` SomeException -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
handler
browsePackageModule :: Ghc (Maybe ModuleInfo)
browsePackageModule = ModuleName -> Maybe FastString -> Ghc Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
G.findModule ModuleName
mdlname Maybe FastString
mpkgid Ghc Module
-> (Module -> Ghc (Maybe ModuleInfo)) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo
browseLocalModule :: Ghc (Maybe ModuleInfo)
browseLocalModule = (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SomeException -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
handler (Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ do
[ModuleString] -> Ghc ()
setTargetFiles [ModuleString
mdl]
ModuleName -> Maybe FastString -> Ghc Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
G.findModule ModuleName
mdlname Maybe FastString
forall a. Maybe a
Nothing Ghc Module
-> (Module -> Ghc (Maybe ModuleInfo)) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo
fallback :: GhcException -> Ghc (Maybe ModuleInfo)
fallback (CmdLineError ModuleString
_) = Ghc (Maybe ModuleInfo)
browseLocalModule
fallback GhcException
_ = Maybe ModuleInfo -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
handler :: SomeException -> m (Maybe a)
handler (SomeException e
_) = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
splitPkgMdl :: String -> (Maybe String,String)
splitPkgMdl :: ModuleString -> (Maybe ModuleString, ModuleString)
splitPkgMdl ModuleString
pkgmdl = case (Char -> Bool) -> ModuleString -> (ModuleString, ModuleString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') ModuleString
pkgmdl of
(ModuleString
mdl,ModuleString
"") -> (Maybe ModuleString
forall a. Maybe a
Nothing,ModuleString
mdl)
(ModuleString
pkg,Char
_:ModuleString
mdl) -> (ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
pkg,ModuleString
mdl)
processExports :: Options -> ModuleInfo -> Ghc [String]
processExports :: Options -> ModuleInfo -> Ghc [ModuleString]
processExports Options
opt ModuleInfo
minfo = (Name -> Ghc ModuleString) -> [Name] -> Ghc [ModuleString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> ModuleInfo -> Name -> Ghc ModuleString
showExport Options
opt ModuleInfo
minfo) ([Name] -> Ghc [ModuleString]) -> [Name] -> Ghc [ModuleString]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
removeOps ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> [Name]
G.modInfoExports ModuleInfo
minfo
where
removeOps :: [Name] -> [Name]
removeOps
| Options -> Bool
operators Options
opt = [Name] -> [Name]
forall a. a -> a
id
| Bool
otherwise = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Bool
isAlpha (Char -> Bool) -> (Name -> Char) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> Char
forall a. [a] -> a
head (ModuleString -> Char) -> (Name -> ModuleString) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString)
showExport :: Options -> ModuleInfo -> Name -> Ghc String
showExport :: Options -> ModuleInfo -> Name -> Ghc ModuleString
showExport Options
opt ModuleInfo
minfo Name
e = do
Maybe ModuleString
mtype' <- Ghc (Maybe ModuleString)
mtype
ModuleString -> Ghc ModuleString
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleString -> Ghc ModuleString)
-> ModuleString -> Ghc ModuleString
forall a b. (a -> b) -> a -> b
$ [ModuleString] -> ModuleString
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ModuleString] -> ModuleString) -> [ModuleString] -> ModuleString
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleString] -> [ModuleString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleString
mqualified, ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just (ModuleString -> Maybe ModuleString)
-> ModuleString -> Maybe ModuleString
forall a b. (a -> b) -> a -> b
$ ModuleString -> ModuleString
formatOp (ModuleString -> ModuleString) -> ModuleString -> ModuleString
forall a b. (a -> b) -> a -> b
$ Name -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString Name
e, Maybe ModuleString
mtype']
where
mqualified :: Maybe ModuleString
mqualified = (ModuleName -> ModuleString
G.moduleNameString (Module -> ModuleName
G.moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
G.nameModule Name
e) ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
".") ModuleString -> Bool -> Maybe ModuleString
forall a. a -> Bool -> Maybe a
`justIf` Options -> Bool
qualified Options
opt
mtype :: Ghc (Maybe ModuleString)
mtype
| Options -> Bool
detailed Options
opt = do
Maybe TyThing
tyInfo <- ModuleInfo -> Name -> Ghc (Maybe TyThing)
forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
G.modInfoLookupName ModuleInfo
minfo Name
e
Maybe TyThing
tyResult <- Ghc (Maybe TyThing)
-> (TyThing -> Ghc (Maybe TyThing))
-> Maybe TyThing
-> Ghc (Maybe TyThing)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Ghc (Maybe TyThing)
inOtherModule Name
e) (Maybe TyThing -> Ghc (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> Ghc (Maybe TyThing))
-> (TyThing -> Maybe TyThing) -> TyThing -> Ghc (Maybe TyThing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just) Maybe TyThing
tyInfo
DynFlags
dflag <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
Maybe ModuleString -> Ghc (Maybe ModuleString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModuleString -> Ghc (Maybe ModuleString))
-> Maybe ModuleString -> Ghc (Maybe ModuleString)
forall a b. (a -> b) -> a -> b
$ do
ModuleString
typeName <- Maybe TyThing
tyResult Maybe TyThing
-> (TyThing -> Maybe ModuleString) -> Maybe ModuleString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> TyThing -> Maybe ModuleString
showThing DynFlags
dflag
(ModuleString
" :: " ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
typeName) ModuleString -> Bool -> Maybe ModuleString
forall a. a -> Bool -> Maybe a
`justIf` Options -> Bool
detailed Options
opt
| Bool
otherwise = Maybe ModuleString -> Ghc (Maybe ModuleString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleString
forall a. Maybe a
Nothing
formatOp :: ModuleString -> ModuleString
formatOp nm :: ModuleString
nm@(Char
n:ModuleString
_)
| Char -> Bool
isAlpha Char
n = ModuleString
nm
| Bool
otherwise = ModuleString
"(" ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
nm ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
")"
formatOp ModuleString
"" = ModuleString -> ModuleString
forall a. HasCallStack => ModuleString -> a
error ModuleString
"formatOp"
inOtherModule :: Name -> Ghc (Maybe TyThing)
inOtherModule :: Name -> Ghc (Maybe TyThing)
inOtherModule Name
nm = Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo (HasDebugCallStack => Name -> Module
Name -> Module
G.nameModule Name
nm) Ghc (Maybe ModuleInfo)
-> Ghc (Maybe TyThing) -> Ghc (Maybe TyThing)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Ghc (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
G.lookupGlobalName Name
nm
justIf :: a -> Bool -> Maybe a
justIf :: a -> Bool -> Maybe a
justIf a
x Bool
True = a -> Maybe a
forall a. a -> Maybe a
Just a
x
justIf a
_ Bool
False = Maybe a
forall a. Maybe a
Nothing
showThing :: DynFlags -> TyThing -> Maybe String
showThing :: DynFlags -> TyThing -> Maybe ModuleString
showThing DynFlags
dflag TyThing
tything = DynFlags -> GapThing -> Maybe ModuleString
showThing' DynFlags
dflag (TyThing -> GapThing
fromTyThing TyThing
tything)
showThing' :: DynFlags -> GapThing -> Maybe String
showThing' :: DynFlags -> GapThing -> Maybe ModuleString
showThing' DynFlags
dflag (GtA Type
a) = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just (ModuleString -> Maybe ModuleString)
-> ModuleString -> Maybe ModuleString
forall a b. (a -> b) -> a -> b
$ DynFlags -> Type -> ModuleString
formatType DynFlags
dflag Type
a
showThing' DynFlags
_ (GtT TyCon
t) = [ModuleString] -> ModuleString
unwords ([ModuleString] -> ModuleString)
-> (ModuleString -> [ModuleString]) -> ModuleString -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> [ModuleString]
toList (ModuleString -> ModuleString)
-> Maybe ModuleString -> Maybe ModuleString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Maybe ModuleString
tyType TyCon
t
where
toList :: ModuleString -> [ModuleString]
toList ModuleString
t' = ModuleString
t' ModuleString -> [ModuleString] -> [ModuleString]
forall a. a -> [a] -> [a]
: TyCon -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString TyCon
t ModuleString -> [ModuleString] -> [ModuleString]
forall a. a -> [a] -> [a]
: (TyVar -> ModuleString) -> [TyVar] -> [ModuleString]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString (TyCon -> [TyVar]
G.tyConTyVars TyCon
t)
showThing' DynFlags
_ GapThing
_ = Maybe ModuleString
forall a. Maybe a
Nothing
formatType :: DynFlags -> Type -> String
formatType :: DynFlags -> Type -> ModuleString
formatType DynFlags
dflag Type
a = DynFlags -> Type -> ModuleString
forall a. Outputable a => DynFlags -> a -> ModuleString
showOutputable DynFlags
dflag (Type -> Type
removeForAlls Type
a)
tyType :: TyCon -> Maybe String
tyType :: TyCon -> Maybe ModuleString
tyType TyCon
typ
| TyCon -> Bool
isAlgTyCon TyCon
typ
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
G.isNewTyCon TyCon
typ)
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
G.isClassTyCon TyCon
typ) = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"data"
| TyCon -> Bool
G.isNewTyCon TyCon
typ = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"newtype"
| TyCon -> Bool
G.isClassTyCon TyCon
typ = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"class"
| TyCon -> Bool
G.isTypeSynonymTyCon TyCon
typ = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"type"
| Bool
otherwise = Maybe ModuleString
forall a. Maybe a
Nothing
removeForAlls :: Type -> Type
removeForAlls :: Type -> Type
removeForAlls Type
ty = Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty' Maybe (Type, Type)
tty'
where
ty' :: Type
ty' = Type -> Type
dropForAlls Type
ty
tty' :: Maybe (Type, Type)
tty' = Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty'
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty Maybe (Type, Type)
Nothing = Type
ty
removeForAlls' Type
ty (Just (Type
pre, Type
ftype))
| HasDebugCallStack => Type -> Bool
Type -> Bool
isPredTy Type
pre = Type -> Type -> Type
mkFunTy Type
pre (Type -> Type
dropForAlls Type
ftype)
| Bool
otherwise = Type
ty
showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable :: DynFlags -> a -> ModuleString
showOutputable DynFlags
dflag = [ModuleString] -> ModuleString
unwords ([ModuleString] -> ModuleString)
-> (a -> [ModuleString]) -> a -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> [ModuleString]
lines (ModuleString -> [ModuleString])
-> (a -> ModuleString) -> a -> [ModuleString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> SDoc -> ModuleString
showPage DynFlags
dflag (DynFlags -> PprStyle
styleUnqualified DynFlags
dflag) (SDoc -> ModuleString) -> (a -> SDoc) -> a -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr