diff --git a/Browse.hs b/Browse.hs index 98d943f..afc899f 100644 --- a/Browse.hs +++ b/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 diff --git a/GHCMod.hs b/GHCMod.hs index 6cdd334..5544838 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -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] [ ...]\n" + ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [ ...]\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \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`)" diff --git a/Types.hs b/Types.hs index 0fb53e2..cbff56f 100644 --- a/Types.hs +++ b/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 }