ghc-mod/GhcMod/Exe/Browse.hs

170 lines
5.6 KiB
Haskell
Raw Normal View History

2016-05-19 16:25:05 +00:00
{-# LANGUAGE CPP #-}
module GhcMod.Exe.Browse (
2015-12-05 20:55:12 +00:00
browse,
BrowseOpts(..)
) where
2010-03-11 10:03:17 +00:00
import Safe
2015-08-03 01:09:56 +00:00
import Control.Applicative
2014-04-24 03:45:47 +00:00
import Control.Exception (SomeException(..))
import Data.Char
import Data.List
import Data.Maybe
import FastString
import GHC
import HscTypes
2014-03-27 05:38:06 +00:00
import qualified GHC as G
import GhcMod.Convert
import GhcMod.Doc (showPage, styleUnqualified)
import GhcMod.Gap as Gap
import GhcMod.Types
import GhcMod.Monad
import GhcMod.Logging
2014-03-27 05:38:06 +00:00
import Name (getOccString)
import Outputable
2014-03-27 05:38:06 +00:00
import TyCon (isAlgTyCon)
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
import Exception (ExceptionMonad, ghandle)
2015-08-03 01:09:56 +00:00
import Prelude
2016-05-19 16:25:05 +00:00
#if __GLASGOW_HASKELL__ >= 800
import PatSyn (pprPatSynType)
#endif
2010-03-11 10:03:17 +00:00
----------------------------------------------------------------
2013-05-20 05:28:56 +00:00
-- | Getting functions, classes, etc from a module.
browse :: forall m. IOish m
2015-12-07 16:57:33 +00:00
=> BrowseOpts -- ^ Configuration parameters
-> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
-> GhcModT m String
2015-12-05 20:55:12 +00:00
browse opts pkgmdl = do
convert' . sort =<< go
2010-04-27 01:28:00 +00:00
where
-- TODO: Add API to Gm.Target to check if module is home module without
-- bringing up a GHC session as well then this can be made a lot cleaner
2015-11-26 15:19:11 +00:00
go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do
goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)
2015-11-26 15:19:11 +00:00
logException ex =
2016-12-15 18:16:37 +00:00
gmLog GmException "browse" $ showToDoc ex
2015-11-26 15:19:11 +00:00
goPkgModule = do
runGmPkgGhc $
2015-12-05 20:55:12 +00:00
processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid
goHomeModule = runGmlT [Right mdlname] $ do
2015-12-05 20:55:12 +00:00
processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m
2015-06-01 14:54:50 +00:00
(mpkg, mdl) = splitPkgMdl pkgmdl
mdlname = G.mkModuleName mdl
mpkgid = mkFastString <$> mpkg
-- |
--
-- >>> splitPkgMdl "base:Prelude"
-- (Just "base","Prelude")
-- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String,String)
2015-06-01 14:54:50 +00:00
splitPkgMdl pkgmdl =
case break (==':') pkgmdl of
(mdl, "") -> (Nothing, mdl)
(pkg, _:mdl) -> (Just pkg, mdl)
-- Haskell 2010:
-- small -> ascSmall | uniSmall | _
-- ascSmall -> a | b | ... | z
-- uniSmall -> any Unicode lowercase letter
-- varid -> (small {small | large | digit | ' })
isNotOp :: String -> Bool
isNotOp (h:_) = isAlpha h || (h == '_')
isNotOp _ = error "isNotOp"
processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
2015-12-05 20:55:12 +00:00
=> BrowseOpts -> ModuleInfo -> m [String]
processExports opt minfo = do
2014-05-10 13:10:34 +00:00
let
removeOps
2015-12-05 20:55:12 +00:00
| optBrowseOperators opt = id
| otherwise = filter (isNotOp . getOccString)
2014-05-14 16:05:40 +00:00
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
2015-12-05 20:55:12 +00:00
=> BrowseOpts -> ModuleInfo -> Name -> m 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
2015-12-05 20:55:12 +00:00
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
mtype :: m (Maybe String)
mtype
| optBrowseDetailed opt || optBrowseParents 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
let sig = do
typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` optBrowseDetailed opt
let parent = do
thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe
2016-05-11 13:58:46 +00:00
(" -- from:" ++ thing) `justIf` optBrowseParents opt
return $ case concat $ catMaybes [sig, parent] of
[] -> Nothing
x -> Just x
| otherwise = return Nothing
formatOp nm
| null nm = error "formatOp"
| isNotOp nm = nm
| otherwise = "(" ++ nm ++ ")"
inOtherModule :: Name -> m (Maybe TyThing)
inOtherModule nm = do
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)
2016-05-19 16:25:05 +00:00
#if __GLASGOW_HASKELL__ >= 800
showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p
#endif
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"
2015-01-16 14:47:56 +00:00
| Gap.isSynTyCon typ = Just "type"
2014-03-27 05:38:06 +00:00
| 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