content: 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 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 . unsafeHead . 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
  -}
  