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

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

-- | 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 = 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

-- | 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
    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
    -- 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 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
        -- "findModule" of GHC 9.2 or earlier throws CmdLineError.
        -- But that of GHC 9.4 does not, sigh.
        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 "base:Prelude"
-- (Just "base","Prelude")
-- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude")
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
        -- If nothing found, load dependent module and lookup global
        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

{-
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
-}