Browse.hs

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 opt cradle pkgmdl = withGHC' $ do
    initializeFlagsWithCradle opt cradle
    browse opt 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 opt pkgmdl = do
    convert opt . sort <$> (getModule >>= listExports)
  where
    (mpkg,mdl) = splitPkgMdl pkgmdl
    mdlname = G.mkModuleName mdl
    mpkgid = mkFastString <$> mpkg
    listExports Nothing       = return []
    listExports (Just mdinfo) = processExports opt 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 = browsePackageModule `catch` fallback `catch` handler
    browsePackageModule = do
        -- "findModule" of GHC 9.2 or earlier throws CmdLineError.
        -- But that of GHC 9.4 does not, sigh.
        mx <- G.findModule mdlname mpkgid >>= G.getModuleInfo
        case mx of
          Just _ -> return mx
          _      -> liftIO $ E.throwIO $ CmdLineError "for GHC 9.4"
    browseLocalModule = handle handler $ do
        setTargetFiles [mdl]
        G.findModule mdlname Nothing >>= G.getModuleInfo
    fallback (CmdLineError _) = browseLocalModule
    fallback _                = return Nothing
    handler (SomeException _) = return Nothing
-- |
--
-- >>> splitPkgMdl "base:Prelude"
-- (Just "base","Prelude")
-- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String,String)
splitPkgMdl pkgmdl = case break (==':') pkgmdl of
    (mdl,"")    -> (Nothing,mdl)
    (pkg,_:mdl) -> (Just pkg,mdl)

processExports :: Options -> ModuleInfo -> Ghc [String]
processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
  where
    removeOps
      | operators opt = id
      | otherwise = filter (isAlpha . head . getOccString)

showExport :: Options -> ModuleInfo -> Name -> Ghc String
showExport opt minfo e = do
  mtype' <- mtype
  return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
  where
    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
    mtype
      | detailed opt = do
        tyInfo <- G.modInfoLookupName minfo e
        -- If nothing found, load dependent module and lookup global
        tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
        dflag <- G.getSessionDynFlags
        return $ do
          typeName <- tyResult >>= showThing dflag
          (" :: " ++ typeName) `justIf` detailed opt
      | otherwise = return Nothing
    formatOp nm@(n:_)
      | isAlpha n = nm
      | otherwise = "(" ++ nm ++ ")"
    formatOp "" = error "formatOp"
    inOtherModule :: Name -> Ghc (Maybe TyThing)
    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
    justIf :: a -> Bool -> Maybe a
    justIf x True = Just x
    justIf _ False = Nothing

showThing :: DynFlags -> TyThing -> Maybe String
showThing dflag tything = showThing' dflag (fromTyThing tything)

showThing' :: DynFlags -> GapThing -> Maybe String
showThing' dflag (GtA a) = Just $ formatType dflag a
showThing' _     (GtT t) = unwords . toList <$> tyType t
  where
    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)
showThing' _     _       = Nothing

formatType :: DynFlags -> Type -> String
formatType dflag a = showOutputable dflag $ removeForAlls a

showOutputable :: DynFlags -> Type -> String
showOutputable dflag = unwords . lines . showPage (initSDocContext dflag styleUnqualified) . pprSigmaType

tyType :: TyCon -> Maybe String
tyType typ
    | isAlgTyCon typ
      && not (G.isNewTyCon typ)
      && not (G.isClassTyCon typ) = Just "data"
    | G.isNewTyCon typ            = Just "newtype"
    | G.isClassTyCon typ          = Just "class"
    | G.isTypeSynonymTyCon typ    = Just "type"
    | otherwise                   = Nothing

removeForAlls :: Type -> Type
removeForAlls = 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
-}