refactoring Browse.
This commit is contained in:
parent
8fe6c99131
commit
9796d639ab
80
Browse.hs
80
Browse.hs
@ -38,52 +38,50 @@ browse opt mdlName = withGHC $ do
|
|||||||
where
|
where
|
||||||
lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo
|
lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo
|
||||||
|
|
||||||
processExports :: ModuleInfo -> [String]
|
processExports :: ModuleInfo -> [String]
|
||||||
processExports = map getOccString . modInfoExports
|
processExports = map getOccString . modInfoExports
|
||||||
|
|
||||||
processModule :: ModuleInfo -> Ghc [String]
|
processModule :: ModuleInfo -> Ghc [String]
|
||||||
processModule minfo = do
|
processModule minfo = do
|
||||||
dynFlags <- getDynFlags
|
dynFlags <- getDynFlags
|
||||||
let processName :: Name -> Ghc String
|
mapM (processName dynFlags) names
|
||||||
processName nm = do
|
where
|
||||||
tyInfo <- modInfoLookupName minfo nm
|
names = modInfoExports minfo
|
||||||
-- If nothing found, load dependent module and lookup global
|
processName :: DynFlags -> Name -> Ghc String
|
||||||
tyResult <- maybe inOtherModule (return . Just) tyInfo
|
processName dynFlags nm = do
|
||||||
return $ fromMaybe name (tyResult >>= showThing dynFlags)
|
tyInfo <- modInfoLookupName minfo nm
|
||||||
where
|
-- If nothing found, load dependent module and lookup global
|
||||||
inOtherModule :: Ghc (Maybe TyThing)
|
tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo
|
||||||
inOtherModule = do
|
return $ fromMaybe (getOccString nm) (tyResult >>= showThing dynFlags)
|
||||||
_ <- getModuleInfo (nameModule nm) -- FIXME
|
inOtherModule :: Name -> Ghc (Maybe TyThing)
|
||||||
lookupGlobalName nm
|
inOtherModule nm = do
|
||||||
name = getOccString nm
|
_ <- getModuleInfo (nameModule nm) -- FIXME
|
||||||
mapM processName exports
|
lookupGlobalName nm
|
||||||
where
|
|
||||||
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 typ -> do
|
ATyCon typ -> do
|
||||||
tyType' <- tyType typ
|
tyType' <- tyType typ
|
||||||
return $ unwords $ [tyType', getOccString typ] ++ map getOccString (tyConTyVars typ)
|
return $ unwords $ [tyType', getOccString typ] ++ map getOccString (tyConTyVars typ)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
tyType :: TyCon -> Maybe String
|
tyType :: TyCon -> Maybe String
|
||||||
tyType typ
|
tyType typ
|
||||||
| isAlgTyCon typ
|
| isAlgTyCon typ
|
||||||
&& not (isNewTyCon typ)
|
&& not (isNewTyCon typ)
|
||||||
&& not (isClassTyCon typ) = Just "data"
|
&& not (isClassTyCon typ) = Just "data"
|
||||||
| isNewTyCon typ = Just "newtype"
|
| isNewTyCon typ = Just "newtype"
|
||||||
| isClassTyCon typ = Just "class"
|
| isClassTyCon typ = Just "class"
|
||||||
| isSynTyCon typ = Just "type"
|
| isSynTyCon typ = Just "type"
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
|
|
||||||
removeForAlls :: Type -> Type
|
removeForAlls :: Type -> Type
|
||||||
removeForAlls ty = case splitFunTy_maybe ty' of
|
removeForAlls ty = case splitFunTy_maybe ty' of
|
||||||
Nothing -> ty'
|
Nothing -> ty'
|
||||||
Just (pre, ftype) -> if isPredTy pre then mkFunTy pre (dropForAlls ftype) else ty'
|
Just (pre, ftype) -> if isPredTy pre then mkFunTy pre (dropForAlls ftype) else ty'
|
||||||
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
|
||||||
|
Loading…
Reference in New Issue
Block a user