hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactoring Browse.hs.

This commit is contained in:
Kazu Yamamoto 2013-02-28 16:33:11 +09:00
parent 66a61b249f
commit 8fe6c99131
1 changed files with 30 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
Browse.hs
View File

@ -1,24 +1,23 @@
module Browse (browseModule) where module Browse (browseModule) where
import Control.Arrow (second)
import Control.Applicative import Control.Applicative
import Data.Char import Data.Char
import Data.List import Data.List
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import DynFlags (getDynFlags) -- FIXME
import GHC import GHC
import GHCApi import GHCApi
import DynFlags (getDynFlags)
import Name import Name
import Types
import Outputable import Outputable
import Var
import TyCon import TyCon
import Type import Type
import Types
import Var
---------------------------------------------------------------- ----------------------------------------------------------------
browseModule :: Options -> String -> IO String browseModule :: Options -> String -> IO String
browseModule opt mdlName = (convert opt . format) <$> browse opt mdlName browseModule opt mdlName = convert opt . format <$> browse opt mdlName
where where
format format
| operators opt = formatOps | operators opt = formatOps
@ -45,38 +44,39 @@ browse opt mdlName = withGHC $ do
processModule :: ModuleInfo -> Ghc [String] processModule :: ModuleInfo -> Ghc [String]
processModule minfo = do processModule minfo = do
dynFlags <- getDynFlags dynFlags <- getDynFlags
let let processName :: Name -> Ghc String
processName :: Name -> Ghc String processName nm = do
processName nm = do tyInfo <- modInfoLookupName minfo nm
tyInfo <- modInfoLookupName minfo nm -- If nothing found, load dependent module and lookup global
-- If nothing found, load dependent module and lookup global tyResult <- maybe inOtherModule (return . Just) tyInfo
tyResult <- maybe inOtherModule (return . Just) tyInfo return $ fromMaybe name (tyResult >>= showThing dynFlags)
return $ fromMaybe name (tyResult >>= showThing dynFlags) where
where inOtherModule :: Ghc (Maybe TyThing)
inOtherModule :: Ghc (Maybe TyThing) inOtherModule = do
inOtherModule = do _ <- getModuleInfo (nameModule nm) -- FIXME
otherModule <- getModuleInfo (nameModule nm) lookupGlobalName nm
lookupGlobalName nm name = getOccString nm
name = getOccString nm
mapM processName exports mapM processName exports
where where
exports = modInfoExports minfo exports = modInfoExports minfo
showThing :: DynFlags -> TyThing -> Maybe String showThing :: DynFlags -> TyThing -> Maybe String
showThing dflags t = case t of showThing dflags t = case t of
(AnId i) -> Just $ getOccString i ++ " :: " ++ showOutputable dflags (removeForAlls $ varType i) AnId i -> Just $ getOccString i ++ " :: " ++ showOutputable dflags (removeForAlls $ varType i)
(ATyCon t) -> do ATyCon typ -> do
tyType' <- tyType t tyType' <- tyType typ
return $ intercalate " " $ [tyType', getOccString t] ++ map getOccString (tyConTyVars t) return $ unwords $ [tyType', getOccString typ] ++ map getOccString (tyConTyVars typ)
_ -> Nothing _ -> Nothing
where where
tyType :: TyCon -> Maybe String tyType :: TyCon -> Maybe String
tyType t tyType typ
| isAlgTyCon t && not (isNewTyCon t) && not (isClassTyCon t) = Just "data" | isAlgTyCon typ
| isNewTyCon t = Just "newtype" && not (isNewTyCon typ)
| isClassTyCon t = Just "class" && not (isClassTyCon typ) = Just "data"
| isSynTyCon t = Just "type" | isNewTyCon typ = Just "newtype"
| otherwise = Nothing | isClassTyCon typ = Just "class"
| isSynTyCon typ = Just "type"
| otherwise = Nothing
removeForAlls :: Type -> Type removeForAlls :: Type -> Type
removeForAlls ty = case splitFunTy_maybe ty' of removeForAlls ty = case splitFunTy_maybe ty' of
@ -85,7 +85,5 @@ browse opt mdlName = withGHC $ do
where where
ty' = dropForAlls ty ty' = dropForAlls ty
showOutputable :: Outputable a => DynFlags -> a -> String showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflags = unwords . lines . showSDocForUser dflags neverQualify . ppr showOutputable dflags = unwords . lines . showSDocForUser dflags neverQualify . ppr