Added detailed info for browse
Rebasing 5 commits: Some cleanup Loads info from dependent module if name is only exported Minor fix Fixed operator to work with -d Drops foralls from function type
This commit is contained in:
parent
2cced9b4bf
commit
66a61b249f
67
Browse.hs
67
Browse.hs
@ -1,17 +1,24 @@
|
||||
module Browse (browseModule) where
|
||||
|
||||
import Control.Arrow (second)
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import GHC
|
||||
import GHCApi
|
||||
import DynFlags (getDynFlags)
|
||||
import Name
|
||||
import Types
|
||||
import Outputable
|
||||
import Var
|
||||
import TyCon
|
||||
import Type
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
browseModule :: Options -> String -> IO String
|
||||
browseModule opt mdlName = convert opt . format <$> browse opt mdlName
|
||||
browseModule opt mdlName = (convert opt . format) <$> browse opt mdlName
|
||||
where
|
||||
format
|
||||
| operators opt = formatOps
|
||||
@ -20,13 +27,65 @@ browseModule opt mdlName = convert opt . format <$> browse opt mdlName
|
||||
formatOps = sort . map formatOps'
|
||||
formatOps' x@(s:_)
|
||||
| isAlpha s = x
|
||||
| otherwise = '(' : 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
|
||||
maybeNamesToStrings <$> lookupModuleInfo
|
||||
lookupModuleInfo >>= maybe (return []) (if detailed opt then processModule else return . processExports)
|
||||
where
|
||||
lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo
|
||||
maybeNamesToStrings = maybe [] (map getOccString . modInfoExports)
|
||||
|
||||
processExports :: ModuleInfo -> [String]
|
||||
processExports = map getOccString . modInfoExports
|
||||
|
||||
processModule :: ModuleInfo -> Ghc [String]
|
||||
processModule minfo = do
|
||||
dynFlags <- getDynFlags
|
||||
let
|
||||
processName :: Name -> Ghc String
|
||||
processName nm = do
|
||||
tyInfo <- modInfoLookupName minfo nm
|
||||
-- If nothing found, load dependent module and lookup global
|
||||
tyResult <- maybe inOtherModule (return . Just) tyInfo
|
||||
return $ fromMaybe name (tyResult >>= showThing dynFlags)
|
||||
where
|
||||
inOtherModule :: Ghc (Maybe TyThing)
|
||||
inOtherModule = do
|
||||
otherModule <- getModuleInfo (nameModule nm)
|
||||
lookupGlobalName nm
|
||||
name = getOccString nm
|
||||
mapM processName exports
|
||||
where
|
||||
exports = modInfoExports minfo
|
||||
|
||||
showThing :: DynFlags -> TyThing -> Maybe String
|
||||
showThing dflags t = case t of
|
||||
(AnId i) -> Just $ getOccString i ++ " :: " ++ showOutputable dflags (removeForAlls $ varType i)
|
||||
(ATyCon t) -> do
|
||||
tyType' <- tyType t
|
||||
return $ intercalate " " $ [tyType', getOccString t] ++ map getOccString (tyConTyVars t)
|
||||
_ -> Nothing
|
||||
where
|
||||
tyType :: TyCon -> Maybe String
|
||||
tyType t
|
||||
| isAlgTyCon t && not (isNewTyCon t) && not (isClassTyCon t) = Just "data"
|
||||
| isNewTyCon t = Just "newtype"
|
||||
| isClassTyCon t = Just "class"
|
||||
| isSynTyCon t = 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
|
||||
|
@ -33,7 +33,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n"
|
||||
++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\n"
|
||||
++ "\t ghc-mod lang [-l]\n"
|
||||
++ "\t ghc-mod flag [-l]\n"
|
||||
++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] <module> [<module> ...]\n"
|
||||
++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] <module> [<module> ...]\n"
|
||||
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"
|
||||
++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFile>\n"
|
||||
++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
|
||||
@ -57,6 +57,9 @@ argspec = [ Option "l" ["tolisp"]
|
||||
, Option "o" ["operators"]
|
||||
(NoArg (\opts -> opts { operators = True }))
|
||||
"print operators, too"
|
||||
, Option "d" ["detailed"]
|
||||
(NoArg (\opts -> opts { detailed = True }))
|
||||
"print detailed info"
|
||||
, Option "s" ["sandbox"]
|
||||
(ReqArg (\s opts -> opts { sandbox = Just s }) "path")
|
||||
"specify cabal-dev sandbox (default 'cabal-dev`)"
|
||||
|
2
Types.hs
2
Types.hs
@ -9,6 +9,7 @@ data Options = Options {
|
||||
, hlintOpts :: [String]
|
||||
, ghcOpts :: [String]
|
||||
, operators :: Bool
|
||||
, detailed :: Bool
|
||||
, expandSplice :: Bool
|
||||
, sandbox :: Maybe String
|
||||
}
|
||||
@ -19,6 +20,7 @@ defaultOptions = Options {
|
||||
, hlintOpts = []
|
||||
, ghcOpts = []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, expandSplice = False
|
||||
, sandbox = Nothing
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user