ghc-mod/Browse.hs

module Browse (browseModule) where

import Control.Applicative
import Data.Char
import Data.List
import Data.Maybe (fromMaybe)
import DynFlags (getDynFlags) -- FIXME
import GHC
import GHCApi
import Name
import Outputable
import TyCon
import Type
import Types
import Var

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

browseModule :: Options -> String -> IO String
browseModule opt mdlName = convert opt . format <$> browse opt mdlName
  where
    format
      | operators opt = formatOps
      | otherwise     = removeOps
    removeOps = sort . filter (isAlpha.head)
    formatOps = sort . map formatOps'
    formatOps' x@(s:_)
      | isAlpha s = x
      | otherwise = "(" ++ name ++ ")" ++ tail_
      where
        (name, tail_) = break isSpace x
    formatOps' [] = error "formatOps'"

browse :: Options -> String -> IO [String]
browse opt mdlName = withGHC $ do
    _ <- initSession0 opt
    lookupModuleInfo >>= maybe (return []) (if detailed opt then processModule else return . processExports)
  where
    lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo

processExports :: ModuleInfo -> [String]
processExports = map getOccString . modInfoExports

processModule :: ModuleInfo -> Ghc [String]
processModule minfo = do
    dynFlags <- getDynFlags
    mapM (processName dynFlags) names
  where
    names = modInfoExports minfo
    processName :: DynFlags -> Name -> Ghc String
    processName dynFlags nm = do
        tyInfo <- modInfoLookupName minfo nm
        -- If nothing found, load dependent module and lookup global
        tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo
        return $ fromMaybe (getOccString nm) (tyResult >>= showThing dynFlags)
    inOtherModule :: Name -> Ghc (Maybe TyThing)
    inOtherModule nm = do
        _ <- getModuleInfo (nameModule nm) -- FIXME
        lookupGlobalName nm

showThing :: DynFlags -> TyThing -> Maybe String
showThing dflags t = case t of
    AnId i -> Just $ getOccString i ++ " :: " ++ showOutputable dflags (removeForAlls $ varType i)
    ATyCon typ -> do
        tyType' <- tyType typ
        return $ unwords $ [tyType', getOccString typ] ++ map getOccString (tyConTyVars typ)
    _ -> Nothing
  where
    tyType :: TyCon -> Maybe String
    tyType typ
        | isAlgTyCon typ
          && not (isNewTyCon typ)
          && not (isClassTyCon typ) = Just "data"
        | isNewTyCon typ            = Just "newtype"
        | isClassTyCon typ          = Just "class"
        | isSynTyCon typ            = Just "type"
        | otherwise                 = Nothing

removeForAlls :: Type -> Type
removeForAlls ty = case splitFunTy_maybe ty' of
    Nothing -> ty'
    Just (pre, ftype) -> if isPredTy pre then mkFunTy pre (dropForAlls ftype) else ty'
  where
    ty' = dropForAlls ty

showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflags = unwords . lines . showSDocForUser dflags neverQualify . ppr