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