Added -q option to list fully qualified names with browse command
This commit is contained in:
parent
d4505041a9
commit
444dd225e1
@ -4,7 +4,7 @@ import Control.Applicative
|
|||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (catMaybes)
|
||||||
import DataCon (dataConRepType)
|
import DataCon (dataConRepType)
|
||||||
import FastString (mkFastString)
|
import FastString (mkFastString)
|
||||||
import GHC
|
import GHC
|
||||||
@ -26,19 +26,7 @@ browseModule :: Options
|
|||||||
-> Cradle
|
-> Cradle
|
||||||
-> ModuleString -- ^ A module name. (e.g. \"Data.List\")
|
-> ModuleString -- ^ A module name. (e.g. \"Data.List\")
|
||||||
-> IO String
|
-> IO String
|
||||||
browseModule opt cradle mdlName = convert opt . format <$> withGHCDummyFile (browse opt cradle mdlName)
|
browseModule opt cradle mdlName = convert opt . sort <$> withGHCDummyFile (browse opt cradle 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'"
|
|
||||||
|
|
||||||
-- | Getting functions, classes, etc from a module.
|
-- | Getting functions, classes, etc from a module.
|
||||||
-- If 'detailed' is 'True', their types are also obtained.
|
-- If 'detailed' is 'True', their types are also obtained.
|
||||||
@ -53,26 +41,42 @@ browse opt cradle mdlName = do
|
|||||||
where
|
where
|
||||||
getModule = findModule (mkModuleName mdlName) (mkFastString <$> packageId opt)
|
getModule = findModule (mkModuleName mdlName) (mkFastString <$> packageId opt)
|
||||||
listExports Nothing = return []
|
listExports Nothing = return []
|
||||||
listExports (Just mdinfo)
|
listExports (Just mdinfo) = processExports opt mdinfo
|
||||||
| detailed opt = processModule mdinfo
|
|
||||||
| otherwise = return (processExports mdinfo)
|
|
||||||
|
|
||||||
processExports :: ModuleInfo -> [String]
|
processExports :: Options -> ModuleInfo -> Ghc [String]
|
||||||
processExports = map getOccString . modInfoExports
|
processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ modInfoExports minfo
|
||||||
|
|
||||||
processModule :: ModuleInfo -> Ghc [String]
|
|
||||||
processModule minfo = mapM processName names
|
|
||||||
where
|
where
|
||||||
names = modInfoExports minfo
|
removeOps
|
||||||
processName :: Name -> Ghc String
|
| operators opt = id
|
||||||
processName nm = do
|
| otherwise = filter (isAlpha . head . getOccString)
|
||||||
tyInfo <- modInfoLookupName minfo nm
|
|
||||||
|
showExport :: Options -> ModuleInfo -> Name -> Ghc String
|
||||||
|
showExport opt minfo e = do
|
||||||
|
mtype' <- mtype
|
||||||
|
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
|
||||||
|
where
|
||||||
|
mqualified
|
||||||
|
| qualified opt = Just $ moduleNameString (moduleName $ nameModule e) ++ "."
|
||||||
|
| otherwise = Nothing
|
||||||
|
mtype
|
||||||
|
| detailed opt = do
|
||||||
|
tyInfo <- modInfoLookupName minfo e
|
||||||
-- If nothing found, load dependent module and lookup global
|
-- If nothing found, load dependent module and lookup global
|
||||||
tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo
|
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
|
||||||
dflag <- getSessionDynFlags
|
dflag <- getSessionDynFlags
|
||||||
return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag)
|
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 :: Name -> Ghc (Maybe TyThing)
|
||||||
inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm
|
inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm
|
||||||
|
justIf :: a -> Bool -> Maybe a
|
||||||
|
justIf x True = Just x
|
||||||
|
justIf _ False = Nothing
|
||||||
|
|
||||||
showThing :: DynFlags -> TyThing -> Maybe String
|
showThing :: DynFlags -> TyThing -> Maybe String
|
||||||
showThing dflag (AnId i) = Just $ formatType dflag varType i
|
showThing dflag (AnId i) = Just $ formatType dflag varType i
|
||||||
@ -83,7 +87,7 @@ showThing _ (ATyCon t) = unwords . toList <$> tyType t
|
|||||||
showThing _ _ = Nothing
|
showThing _ _ = Nothing
|
||||||
|
|
||||||
formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String
|
formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String
|
||||||
formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x)
|
formatType dflag f x = showOutputable dflag (removeForAlls $ f x)
|
||||||
|
|
||||||
tyType :: TyCon -> Maybe String
|
tyType :: TyCon -> Maybe String
|
||||||
tyType typ
|
tyType typ
|
||||||
|
@ -17,6 +17,8 @@ data Options = Options {
|
|||||||
, operators :: Bool
|
, operators :: Bool
|
||||||
-- | If 'True', 'browse' also returns types.
|
-- | If 'True', 'browse' also returns types.
|
||||||
, detailed :: Bool
|
, detailed :: Bool
|
||||||
|
-- | If 'True', 'browse' will return fully qualified name
|
||||||
|
, qualified :: Bool
|
||||||
-- | Whether or not Template Haskell should be expanded.
|
-- | Whether or not Template Haskell should be expanded.
|
||||||
, expandSplice :: Bool
|
, expandSplice :: Bool
|
||||||
-- | Line separator string.
|
-- | Line separator string.
|
||||||
@ -33,6 +35,7 @@ defaultOptions = Options {
|
|||||||
, ghcOpts = []
|
, ghcOpts = []
|
||||||
, operators = False
|
, operators = False
|
||||||
, detailed = False
|
, detailed = False
|
||||||
|
, qualified = False
|
||||||
, expandSplice = False
|
, expandSplice = False
|
||||||
, lineSeparator = LineSeparator "\0"
|
, lineSeparator = LineSeparator "\0"
|
||||||
, packageId = Nothing
|
, packageId = Nothing
|
||||||
|
@ -27,7 +27,7 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n"
|
|||||||
++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l] [-d]\n"
|
++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l] [-d]\n"
|
||||||
++ "\t ghc-mod lang [-l]\n"
|
++ "\t ghc-mod lang [-l]\n"
|
||||||
++ "\t ghc-mod flag [-l]\n"
|
++ "\t ghc-mod flag [-l]\n"
|
||||||
++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-p package] <module> [<module> ...]\n"
|
++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [-p package] <module> [<module> ...]\n"
|
||||||
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
|
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
|
||||||
++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
|
++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
|
||||||
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\n"
|
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\n"
|
||||||
@ -55,6 +55,9 @@ argspec = [ Option "l" ["tolisp"]
|
|||||||
, Option "d" ["detailed"]
|
, Option "d" ["detailed"]
|
||||||
(NoArg (\opts -> opts { detailed = True }))
|
(NoArg (\opts -> opts { detailed = True }))
|
||||||
"print detailed info"
|
"print detailed info"
|
||||||
|
, Option "q" ["qualified"]
|
||||||
|
(NoArg (\opts -> opts { qualified = True }))
|
||||||
|
"show qualified names"
|
||||||
, Option "p" ["package"]
|
, Option "p" ["package"]
|
||||||
(ReqArg (\p opts -> opts { packageId = Just p, ghcOpts = ("-package " ++ p) : ghcOpts opts }) "package-id")
|
(ReqArg (\p opts -> opts { packageId = Just p, ghcOpts = ("-package " ++ p) : ghcOpts opts }) "package-id")
|
||||||
"specify package of module"
|
"specify package of module"
|
||||||
|
Loading…
Reference in New Issue
Block a user