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

type for FunBind

Browse Source
This commit is contained in:
eagletmt 2012-02-18 18:17:47 +09:00
parent 8a8b4ae9fb
commit bf93fcab12
1 changed files with 17 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Info.hs
View File

@ -55,8 +55,10 @@ typeOf opt fileName modstr lineNo colNo =
p <- parseModule modSum p <- parseModule modSum
tcm <- typecheckModule p tcm <- typecheckModule p
let es = findExpr tcm lineNo colNo let es = findExpr tcm lineNo colNo
ts <- catMaybes <$> mapM (getType tcm) es ets <- catMaybes <$> mapM (getExprType tcm) es
let sss = map toTup $ sortBy (cmp `on` fst) ts let bs = findBind tcm lineNo colNo
bts = catMaybes $ map getBindType bs
let sss = map toTup $ sortBy (cmp `on` fst) $ ets ++ bts
return $ convert opt sss return $ convert opt sss
toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String) toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
@ -80,11 +82,18 @@ findExpr tcm line col =
f :: LHsExpr Id -> Bool f :: LHsExpr Id -> Bool
f (L spn _) = isGoodSrcSpan spn && spn `spans` (line, col) f (L spn _) = isGoodSrcSpan spn && spn `spans` (line, col)
findBind :: TypecheckedModule -> Int -> Int -> [LHsBind Id]
findBind TypecheckedModule{tm_typechecked_source = src} line col = listifyStaged TypeChecker f src
where
f :: LHsBind Id -> Bool
f (L _ (FunBind{fun_id = L spn _})) = isGoodSrcSpan spn && spn `spans` (line, col)
f _ = False
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type)) getExprType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type))
getType tcm e = do getExprType tcm e = do
hs_env <- getSession hs_env <- getSession
(_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e
return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe
@ -93,6 +102,10 @@ getType tcm e = do
rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
ty_env = tcg_type_env $ fst $ tm_internals_ tcm ty_env = tcg_type_env $ fst $ tm_internals_ tcm
getBindType :: LHsBind Id -> Maybe (SrcSpan, Type)
getBindType (L _ FunBind{fun_id = L spn _, fun_matches = MatchGroup _ typ}) = Just (spn, typ)
getBindType _ = Nothing
pretty :: Type -> String pretty :: Type -> String
pretty = showDocWith OneLineMode . withPprStyleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False pretty = showDocWith OneLineMode . withPprStyleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False