module Hhp.Browse (
    browseModule,
    browse,
) where

import GHC (
    DynFlags,
    Ghc,
    GhcException (CmdLineError),
    ModuleInfo,
    Name,
    TyCon,
    TyThing,
    Type,
 )
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 (..), catch, handle)
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

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

-- | Getting functions, classes, etc from a module.
--   If 'detailed' is 'True', their types are also obtained.
--   If 'operators' is 'True', operators are also returned.
browseModule
    :: Options
    -> Cradle
    -> ModuleString
    -- ^ A module name. (e.g. \"Data.List\")
    -> IO String
browseModule :: Options -> Cradle -> String -> IO String
browseModule Options
opt Cradle
cradle String
pkgmdl = Ghc String -> IO String
forall a. Ghc a -> IO a
withGHC' (Ghc String -> IO String) -> Ghc String -> IO String
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

-- | Getting functions, classes, etc from a module.
--   If 'detailed' is 'True', their types are also obtained.
--   If 'operators' is 'True', operators are also returned.
browse
    :: Options
    -> ModuleString
    -- ^ A module name. (e.g. \"Data.List\")
    -> Ghc String
browse :: Options -> String -> Ghc String
browse Options
opt String
pkgmdl = do
    Options -> [String] -> String
forall a. ToString a => Options -> a -> String
convert Options
opt ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> String) -> Ghc [String] -> Ghc String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ghc (Maybe ModuleInfo)
getModule Ghc (Maybe ModuleInfo)
-> (Maybe ModuleInfo -> Ghc [String]) -> Ghc [String]
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
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 (String -> FastString) -> Maybe String -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mpkg
    listExports :: Maybe ModuleInfo -> Ghc [String]
listExports Maybe ModuleInfo
Nothing = [String] -> Ghc [String]
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    listExports (Just ModuleInfo
mdinfo) = Options -> ModuleInfo -> Ghc [String]
processExports Options
opt ModuleInfo
mdinfo
    -- findModule works only for package modules, moreover,
    -- you cannot load a package module. On the other hand,
    -- to browse a local module you need to load it first.
    -- If CmdLineError is signalled, we assume the user
    -- tried browsing a local module.
    getModule :: Ghc (Maybe ModuleInfo)
getModule = Ghc (Maybe ModuleInfo)
browsePackageModule Ghc (Maybe ModuleInfo)
-> (GhcException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` GhcException -> Ghc (Maybe ModuleInfo)
fallback Ghc (Maybe ModuleInfo)
-> (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> Ghc (Maybe ModuleInfo)
forall {m :: * -> *} {a}. Monad m => SomeException -> m (Maybe a)
handler
    browsePackageModule :: Ghc (Maybe ModuleInfo)
browsePackageModule = do
        -- "findModule" of GHC 9.2 or earlier throws CmdLineError.
        -- But that of GHC 9.4 does not, sigh.
        Maybe ModuleInfo
mx <- 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 a b. Ghc a -> (a -> Ghc b) -> Ghc b
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
        case Maybe ModuleInfo
mx of
            Just ModuleInfo
_ -> Maybe ModuleInfo -> Ghc (Maybe ModuleInfo)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
mx
            Maybe ModuleInfo
_ -> IO (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ GhcException -> IO (Maybe ModuleInfo)
forall e a. Exception e => e -> IO a
E.throwIO (GhcException -> IO (Maybe ModuleInfo))
-> GhcException -> IO (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError String
"for GHC 9.4"
    browseLocalModule :: Ghc (Maybe ModuleInfo)
browseLocalModule = (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle 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
        [String] -> Ghc ()
setTargetFiles [String
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 a b. Ghc a -> (a -> Ghc b) -> Ghc b
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 String
_) = Ghc (Maybe ModuleInfo)
browseLocalModule
    fallback GhcException
_ = Maybe ModuleInfo -> Ghc (Maybe ModuleInfo)
forall a. a -> Ghc a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- |
--
-- >>> splitPkgMdl "base:Prelude"
-- (Just "base","Prelude")
-- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String, String)
splitPkgMdl :: String -> (Maybe String, String)
splitPkgMdl String
pkgmdl = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
pkgmdl of
    (String
mdl, String
"") -> (Maybe String
forall a. Maybe a
Nothing, String
mdl)
    (String
pkg, Char
_ : String
mdl) -> (String -> Maybe String
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 = (Name -> Ghc String) -> [Name] -> Ghc [String]
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) -> [a] -> m [b]
mapM (Options -> ModuleInfo -> Name -> Ghc String
showExport Options
opt ModuleInfo
minfo) ([Name] -> Ghc [String]) -> [Name] -> Ghc [String]
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
. String -> Char
forall a. [a] -> a
unsafeHead (String -> Char) -> (Name -> String) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
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
    String -> Ghc String
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ghc String) -> String -> Ghc String
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
mqualified, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
formatOp (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
getOccString Name
e, Maybe String
mtype']
  where
    mqualified :: Maybe String
mqualified =
        (ModuleName -> String
G.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
G.moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Name -> Module
Name -> Module
G.nameModule Name
e) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
            String -> Bool -> Maybe 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 <- ModuleInfo -> Name -> Ghc (Maybe TyThing)
forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
G.modInfoLookupName ModuleInfo
minfo Name
e
            -- If nothing found, load dependent module and lookup global
            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 a. a -> Ghc a
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 String -> Ghc (Maybe String)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> Ghc (Maybe String))
-> Maybe String -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                String
typeName <- Maybe TyThing
tyResult Maybe TyThing -> (TyThing -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> TyThing -> Maybe String
showThing DynFlags
dflag
                (String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName) String -> Bool -> Maybe String
forall a. a -> Bool -> Maybe a
`justIf` Options -> Bool
detailed Options
opt
        | Bool
otherwise = Maybe String -> Ghc (Maybe String)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    formatOp String
"" = String -> String
forall a. HasCallStack => String -> a
error String
"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 ((() :: Constraint) => Name -> Module
Name -> Module
G.nameModule Name
nm) Ghc (Maybe ModuleInfo)
-> Ghc (Maybe TyThing) -> Ghc (Maybe TyThing)
forall a b. Ghc a -> Ghc b -> Ghc b
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 :: forall a. 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 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) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ DynFlags -> Type -> String
formatType DynFlags
dflag Type
a
showThing' DynFlags
_ (GtT TyCon
t) = [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
toList (String -> String) -> Maybe String -> Maybe String
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' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: TyCon -> String
forall a. NamedThing a => a -> String
getOccString TyCon
t String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (TyVar -> String) -> [TyVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> String
forall a. NamedThing a => a -> String
getOccString (TyCon -> [TyVar]
G.tyConTyVars TyCon
t)
showThing' DynFlags
_ GapThing
_ = Maybe String
forall a. Maybe a
Nothing

formatType :: DynFlags -> Type -> String
formatType :: DynFlags -> Type -> String
formatType DynFlags
dflag Type
a = DynFlags -> Type -> String
showOutputable DynFlags
dflag (Type -> String) -> Type -> String
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
        ([String] -> String) -> (Type -> [String]) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
        (String -> [String]) -> (Type -> String) -> Type -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
showPage (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflag PprStyle
styleUnqualified)
        (SDoc -> String) -> (Type -> SDoc) -> Type -> String
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) =
        String -> Maybe String
forall a. a -> Maybe a
Just String
"data"
    | TyCon -> Bool
G.isNewTyCon TyCon
typ = String -> Maybe String
forall a. a -> Maybe a
Just String
"newtype"
    | TyCon -> Bool
G.isClassTyCon TyCon
typ = String -> Maybe String
forall a. a -> Maybe a
Just String
"class"
    | TyCon -> Bool
G.isTypeSynonymTyCon TyCon
typ = String -> Maybe String
forall a. a -> Maybe a
Just String
"type"
    | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

removeForAlls :: Type -> Type
removeForAlls :: Type -> Type
removeForAlls = Type -> Type
dropForAlls

{-
removeForAlls :: Type -> Type
removeForAlls ty = removeForAlls' ty' tty'
  where
    ty'  = dropForAlls ty
    tty' = splitFunTy_maybe ty'

removeForAlls' :: Type -> Maybe (Type, Type, Type) -> Type
removeForAlls' ty Nothing = ty
removeForAlls' ty (Just (pre, ftype, x))
    | isPredTy pre        = mkVisFunTy pre (dropForAlls ftype) x
    | otherwise           = ty
-}