ghc-mod/Language/Haskell/GhcMod/Info.hs

139 lines
5.0 KiB
Haskell
Raw Normal View History

2014-04-11 02:13:24 +00:00
{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
2011-08-24 06:58:12 +00:00
2013-05-20 05:28:56 +00:00
module Language.Haskell.GhcMod.Info (
infoExpr
, info
, typeExpr
2014-04-21 05:04:58 +00:00
, types
2013-05-20 05:28:56 +00:00
) where
2010-11-12 07:27:50 +00:00
2014-01-08 03:03:32 +00:00
import Control.Applicative ((<$>))
2014-03-27 06:08:07 +00:00
import CoreMonad (liftIO)
2014-01-08 03:03:32 +00:00
import CoreUtils (exprType)
import Data.Function (on)
2014-04-21 05:04:58 +00:00
import Data.Generics
2014-01-08 03:03:32 +00:00
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
2012-02-12 16:01:58 +00:00
import Data.Ord as O
import Exception (ghandle, SomeException(..))
2014-04-24 03:15:59 +00:00
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L))
2014-03-27 06:56:14 +00:00
import qualified GHC as G
2014-01-08 03:03:32 +00:00
import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.GHCApi
2014-06-09 08:30:33 +00:00
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
2014-03-27 06:56:14 +00:00
import qualified Language.Haskell.GhcMod.Gap as Gap
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.Types
2014-05-11 22:40:00 +00:00
import Language.Haskell.GhcMod.Convert
import Outputable (PprStyle)
2012-02-18 10:14:29 +00:00
import TcHsSyn (hsPatType)
2012-02-14 07:09:53 +00:00
----------------------------------------------------------------
2011-08-24 06:58:12 +00:00
2013-05-20 05:28:56 +00:00
-- | Obtaining information of a target expression. (GHCi's info:)
infoExpr :: Options
-> Cradle
2013-09-05 05:35:28 +00:00
-> FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression.
2013-05-20 05:28:56 +00:00
-> IO String
infoExpr opt cradle file expr = withGHC' $ do
initializeFlagsWithCradle opt cradle
info opt file expr
2013-05-20 05:28:56 +00:00
-- | Obtaining information of a target expression. (GHCi's info:)
2014-04-21 00:45:41 +00:00
info :: Options
-> FilePath -- ^ A target file.
2013-09-05 05:35:28 +00:00
-> Expression -- ^ A Haskell expression.
2013-05-20 05:28:56 +00:00
-> Ghc String
2014-04-23 07:37:24 +00:00
info opt file expr = convert opt <$> ghandle handler body
where
2014-04-27 12:26:03 +00:00
body = inModuleContext file $ \dflag style -> do
2014-04-23 07:37:24 +00:00
sdoc <- Gap.infoThing expr
return $ showPage dflag style sdoc
handler (SomeException _) = return "Cannot show info"
2011-01-14 02:18:33 +00:00
2012-02-12 12:04:18 +00:00
----------------------------------------------------------------
2013-11-12 23:44:34 +00:00
instance HasType (LHsExpr Id) where
getType tcm e = do
2014-03-27 06:56:14 +00:00
hs_env <- G.getSession
2014-03-27 06:08:07 +00:00
mbe <- liftIO $ Gap.deSugar tcm e hs_env
2014-03-27 06:56:14 +00:00
return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
2012-02-18 11:02:37 +00:00
instance HasType (LPat Id) where
2014-03-27 06:56:14 +00:00
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
2012-02-18 11:02:37 +00:00
2013-05-20 05:28:56 +00:00
----------------------------------------------------------------
2012-02-12 12:04:18 +00:00
2013-05-20 05:28:56 +00:00
-- | Obtaining type of a target expression. (GHCi's type:)
typeExpr :: Options
-> Cradle
2013-09-05 05:35:28 +00:00
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
2013-05-20 05:28:56 +00:00
-> IO String
typeExpr opt cradle file lineNo colNo = withGHC' $ do
initializeFlagsWithCradle opt cradle
types opt file lineNo colNo
2013-05-20 05:28:56 +00:00
-- | Obtaining type of a target expression. (GHCi's type:)
2014-04-21 05:04:58 +00:00
types :: Options
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Ghc String
2014-04-23 07:37:24 +00:00
types opt file lineNo colNo = convert opt <$> ghandle handler body
where
2014-04-27 12:26:03 +00:00
body = inModuleContext file $ \dflag style -> do
modSum <- Gap.fileModSummary file
2014-04-23 07:37:24 +00:00
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
2014-04-26 14:03:50 +00:00
return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
handler (SomeException _) = return []
2012-02-15 05:52:48 +00:00
2014-04-11 03:19:42 +00:00
getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
getSrcSpanType modSum lineNo colNo = do
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
bts <- mapM (getType tcm) bs
ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts]
2012-02-18 11:02:37 +00:00
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
listifySpans tcs lc = listifyStaged TypeChecker p tcs
2012-02-18 09:17:47 +00:00
where
2014-03-27 06:56:14 +00:00
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
2012-02-18 10:14:29 +00:00
2012-02-13 18:20:33 +00:00
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
2012-02-14 07:19:48 +00:00
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
2012-02-12 12:04:18 +00:00
2014-04-11 03:19:42 +00:00
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
| a `G.isSubspanOf` b = O.LT
| b `G.isSubspanOf` a = O.GT
| otherwise = O.EQ
toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag style = showOneLine dflag style . Gap.typeForUser
2012-02-13 04:23:04 +00:00
2010-11-15 05:46:59 +00:00
----------------------------------------------------------------
2014-04-27 12:26:03 +00:00
inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a
2014-04-28 03:52:09 +00:00
inModuleContext file action =
2014-06-09 08:30:33 +00:00
withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
setTargetFiles [file]
2014-04-27 12:26:03 +00:00
Gap.withContext $ do
dflag <- G.getSessionDynFlags
style <- getStyle
action dflag style