ghc-mod/Language/Haskell/GhcMod/Browse.hs

163 lines
6.0 KiB
Haskell
Raw Normal View History

2014-03-25 02:14:16 +00:00
module Language.Haskell.GhcMod.Browse (
browseModule
, browse
, browseAll)
where
2010-03-11 10:03:17 +00:00
2014-03-27 05:38:06 +00:00
import Control.Applicative ((<$>))
2014-04-24 03:45:47 +00:00
import Control.Exception (SomeException(..))
2014-03-27 05:38:06 +00:00
import Data.Char (isAlpha)
import Data.List (sort)
import Data.Maybe (catMaybes)
2014-04-24 03:45:47 +00:00
import Exception (ghandle)
import FastString (mkFastString)
2014-03-27 05:38:06 +00:00
import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
import qualified GHC as G
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.GHCApi
2014-02-06 12:34:40 +00:00
import Language.Haskell.GhcMod.Gap
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.Types
2014-03-27 05:38:06 +00:00
import Name (getOccString)
import Outputable (ppr, Outputable)
import TyCon (isAlgTyCon)
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
2010-03-11 10:03:17 +00:00
----------------------------------------------------------------
2013-05-20 05:28:56 +00:00
-- | Getting functions, classes, etc from a module.
-- If 'detailed' is 'True', their types are also obtained.
2013-09-05 05:35:28 +00:00
-- If 'operators' is 'True', operators are also returned.
2013-05-20 05:28:56 +00:00
browseModule :: Options
-> Cradle
2013-05-20 05:28:56 +00:00
-> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-> IO String
browseModule opt cradle pkgmdl = withGHC' $ do
initializeFlagsWithCradle opt cradle []
browse opt pkgmdl
2010-03-11 10:03:17 +00:00
2013-05-20 05:28:56 +00:00
-- | Getting functions, classes, etc from a module.
-- If 'detailed' is 'True', their types are also obtained.
2013-09-05 05:35:28 +00:00
-- If 'operators' is 'True', operators are also returned.
2013-05-20 05:28:56 +00:00
browse :: Options
-> ModuleString -- ^ A module name. (e.g. \"Data.List\")
2014-04-21 03:46:14 +00:00
-> Ghc String
browse opt pkgmdl = do
2014-04-24 03:45:47 +00:00
convert opt . sort <$> (getModule >>= listExports)
2010-04-27 01:28:00 +00:00
where
(mpkg,mdl) = splitPkgMdl pkgmdl
mdlname = G.mkModuleName mdl
mpkgid = mkFastString <$> mpkg
2013-03-01 01:16:31 +00:00
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.
2014-04-24 03:45:47 +00:00
getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler
browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo
browseLocalModule = ghandle handler $ do
setTargetFiles [mdl]
2014-04-24 03:45:47 +00:00
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]
2014-03-27 05:38:06 +00:00
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']
2013-02-28 17:24:14 +00:00
where
2014-03-27 05:38:06 +00:00
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
mtype
| detailed opt = do
2014-03-27 05:38:06 +00:00
tyInfo <- G.modInfoLookupName minfo e
2013-02-28 17:24:14 +00:00
-- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
2014-03-27 05:38:06 +00:00
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"
2013-02-28 17:24:14 +00:00
inOtherModule :: Name -> Ghc (Maybe TyThing)
2014-03-27 05:38:06 +00:00
inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
justIf :: a -> Bool -> Maybe a
justIf x True = Just x
justIf _ False = Nothing
2013-03-12 13:15:23 +00:00
showThing :: DynFlags -> TyThing -> Maybe String
2014-02-06 12:34:40 +00:00
showThing dflag tything = showThing' dflag (fromTyThing tything)
showThing' :: DynFlags -> GapThing -> Maybe String
2014-02-06 13:09:00 +00:00
showThing' dflag (GtA a) = Just $ formatType dflag a
2014-02-06 12:34:40 +00:00
showThing' _ (GtT t) = unwords . toList <$> tyType t
2013-02-28 17:24:14 +00:00
where
2014-03-27 05:38:06 +00:00
toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)
2014-02-06 12:34:40 +00:00
showThing' _ _ = Nothing
2013-03-01 01:16:31 +00:00
2014-02-06 13:09:00 +00:00
formatType :: DynFlags -> Type -> String
formatType dflag a = showOutputable dflag (removeForAlls a)
2013-03-01 01:16:31 +00:00
tyType :: TyCon -> Maybe String
tyType typ
| isAlgTyCon typ
2014-03-27 05:38:06 +00:00
&& not (G.isNewTyCon typ)
&& not (G.isClassTyCon typ) = Just "data"
| G.isNewTyCon typ = Just "newtype"
| G.isClassTyCon typ = Just "class"
| G.isSynTyCon typ = Just "type"
| otherwise = Nothing
2013-02-28 17:24:14 +00:00
removeForAlls :: Type -> Type
2013-03-01 01:16:31 +00:00
removeForAlls ty = removeForAlls' ty' tty'
2013-02-28 17:24:14 +00:00
where
2013-03-01 01:16:31 +00:00
ty' = dropForAlls ty
tty' = splitFunTy_maybe ty'
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' ty Nothing = ty
removeForAlls' ty (Just (pre, ftype))
| isPredTy pre = mkFunTy pre (dropForAlls ftype)
| otherwise = ty
2013-03-12 13:15:23 +00:00
showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
2014-03-25 02:14:16 +00:00
----------------------------------------------------------------
2014-03-26 03:09:02 +00:00
-- | Browsing all functions in all system/user modules.
2014-03-25 02:14:16 +00:00
browseAll :: DynFlags -> Ghc [(String,String)]
browseAll dflag = do
2014-03-27 05:38:06 +00:00
ms <- G.packageDbModules True
is <- mapM G.getModuleInfo ms
2014-03-25 02:14:16 +00:00
return $ concatMap (toNameModule dflag) (zip ms is)
toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]
toNameModule _ (_,Nothing) = []
toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names
where
2014-03-27 05:38:06 +00:00
mdl = G.moduleNameString (G.moduleName m)
names = G.modInfoExports inf
toStr = showOneLine dflag styleUnqualified . ppr