{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
module Hhp.Info (
infoExpr
, info
, typeExpr
, types
) where
import GHC (Ghc, TypecheckedModule(..), SrcSpan, Type, GenLocated(L), ModSummary, mgModSummaries, mg_ext, LHsBind, Type, LPat, LHsExpr)
import qualified GHC as G
import GHC.Core.Utils (exprType)
import GHC.Hs.Binds (HsBindLR(..))
import GHC.Hs.Expr (MatchGroupTc(..))
import GHC.Hs.Extension (GhcTc)
import GHC.HsToCore (deSugarExpr)
import GHC.Utils.Monad (liftIO)
import GHC.Utils.Outputable (SDocContext)
import GHC.Driver.Session (initSDocContext)
import Control.Applicative ((<|>))
import Control.Monad (filterM)
import Control.Monad.Catch (SomeException(..), handle, bracket)
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O
import Hhp.Doc (showPage, showOneLine, getStyle)
import Hhp.Gap
import Hhp.GHCApi
import Hhp.Logger (getSrcSpan)
import Hhp.Syb
import Hhp.Things
import Hhp.Types
infoExpr :: Options
-> Cradle
-> FilePath
-> Expression
-> IO String
infoExpr :: Options -> Cradle -> String -> String -> IO String
infoExpr Options
opt Cradle
cradle String
file String
expr = forall a. Ghc a -> IO a
withGHC' forall a b. (a -> b) -> a -> b
$ do
Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
Options -> String -> String -> Ghc String
info Options
opt String
file String
expr
info :: Options
-> FilePath
-> Expression
-> Ghc String
info :: Options -> String -> String -> Ghc String
info Options
opt String
file String
expr = forall a. ToString a => Options -> a -> String
convert Options
opt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall {m :: * -> *}. Monad m => SomeException -> m String
handler Ghc String
body
where
body :: Ghc String
body = forall a. String -> (SDocContext -> Ghc a) -> Ghc a
inModuleContext String
file forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx -> do
SDoc
sdoc <- String -> Ghc SDoc
infoThing String
expr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
sdoc
handler :: SomeException -> m String
handler (SomeException e
_e) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"Cannot show info: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
_e
typeExpr :: Options
-> Cradle
-> FilePath
-> Int
-> Int
-> IO String
typeExpr :: Options -> Cradle -> String -> Int -> Int -> IO String
typeExpr Options
opt Cradle
cradle String
file Int
lineNo Int
colNo = forall a. Ghc a -> IO a
withGHC' forall a b. (a -> b) -> a -> b
$ do
Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
Options -> String -> Int -> Int -> Ghc String
types Options
opt String
file Int
lineNo Int
colNo
types :: Options
-> FilePath
-> Int
-> Int
-> Ghc String
types :: Options -> String -> Int -> Int -> Ghc String
types Options
opt String
file Int
lineNo Int
colNo = forall a. ToString a => Options -> a -> String
convert Options
opt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall {m :: * -> *} {a}. Monad m => SomeException -> m [a]
handler Ghc [((Int, Int, Int, Int), String)]
body
where
body :: Ghc [((Int, Int, Int, Int), String)]
body = forall a. String -> (SDocContext -> Ghc a) -> Ghc a
inModuleContext String
file forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx -> do
ModSummary
modSum <- String -> Ghc ModSummary
fileModSummary String
file
[(SrcSpan, Type)]
srcSpanTypes <- ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
getSrcSpanType ModSummary
modSum Int
lineNo Int
colNo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SDocContext -> (SrcSpan, Type) -> ((Int, Int, Int, Int), String)
toTup SDocContext
ctx) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
cmp forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(SrcSpan, Type)]
srcSpanTypes
handler :: SomeException -> m [a]
handler (SomeException e
_) = forall (m :: * -> *) a. Monad m => a -> m a
return []
type LExpression = LHsExpr GhcTc
type LBinding = LHsBind GhcTc
type LPattern = LPat GhcTc
getSrcSpanType :: ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
getSrcSpanType :: ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
getSrcSpanType ModSummary
modSum Int
lineNo Int
colNo = do
ParsedModule
p <- forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
G.parseModule ModSummary
modSum
tcm :: TypecheckedModule
tcm@TypecheckedModule{tm_typechecked_source :: TypecheckedModule -> TypecheckedSource
tm_typechecked_source = TypecheckedSource
tcs} <- forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
G.typecheckModule ParsedModule
p
let es :: [LExpression]
es = forall a. Typeable a => TypecheckedSource -> (Int, Int) -> [LOC a]
listifySpans TypecheckedSource
tcs (Int
lineNo, Int
colNo) :: [LExpression]
bs :: [LBinding]
bs = forall a. Typeable a => TypecheckedSource -> (Int, Int) -> [LOC a]
listifySpans TypecheckedSource
tcs (Int
lineNo, Int
colNo) :: [LBinding]
ps :: [LPattern]
ps = forall a. Typeable a => TypecheckedSource -> (Int, Int) -> [LOC a]
listifySpans TypecheckedSource
tcs (Int
lineNo, Int
colNo) :: [LPattern]
[Maybe (SrcSpan, Type)]
ets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type))
getTypeLExpression TypecheckedModule
tcm) [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
es
[Maybe (SrcSpan, Type)]
bts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type))
getTypeLBinding TypecheckedModule
tcm) [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs
[Maybe (SrcSpan, Type)]
pts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypecheckedModule -> LPattern -> Ghc (Maybe (SrcSpan, Type))
getTypeLPattern TypecheckedModule
tcm) [GenLocated SrcSpanAnnA (Pat GhcTc)]
ps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Maybe (SrcSpan, Type)]
ets, [Maybe (SrcSpan, Type)]
bts, [Maybe (SrcSpan, Type)]
pts]
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp SrcSpan
a SrcSpan
b
| SrcSpan
a SrcSpan -> SrcSpan -> Bool
`G.isSubspanOf` SrcSpan
b = Ordering
O.LT
| SrcSpan
b SrcSpan -> SrcSpan -> Bool
`G.isSubspanOf` SrcSpan
a = Ordering
O.GT
| Bool
otherwise = Ordering
O.EQ
toTup :: SDocContext -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup :: SDocContext -> (SrcSpan, Type) -> ((Int, Int, Int, Int), String)
toTup SDocContext
ctx (SrcSpan
spn, Type
typ) = (SrcSpan -> (Int, Int, Int, Int)
fourInts SrcSpan
spn, SDocContext -> Type -> String
pretty SDocContext
ctx Type
typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts :: SrcSpan -> (Int, Int, Int, Int)
fourInts = forall a. a -> Maybe a -> a
fromMaybe (Int
0,Int
0,Int
0,Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe (Int, Int, Int, Int)
getSrcSpan
pretty :: SDocContext -> Type -> String
pretty :: SDocContext -> Type -> String
pretty SDocContext
ctx = SDocContext -> SDoc -> String
showOneLine SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> SDoc
pprSigmaType
inModuleContext :: FilePath -> (SDocContext -> Ghc a) -> Ghc a
inModuleContext :: forall a. String -> (SDocContext -> Ghc a) -> Ghc a
inModuleContext String
file SDocContext -> Ghc a
action =
forall a. (DynFlags -> DynFlags) -> Ghc a -> Ghc a
withDynFlags (DynFlags -> DynFlags
setWarnTypedHoles forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
setDeferTypeErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
setNoWarningFlags) forall a b. (a -> b) -> a -> b
$ do
[String] -> Ghc ()
setTargetFiles [String
file]
forall a. Ghc a -> Ghc a
withContext forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflag <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
PprStyle
style <- Ghc PprStyle
getStyle
SDocContext -> Ghc a
action forall a b. (a -> b) -> a -> b
$ DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflag PprStyle
style
fileModSummary :: FilePath -> Ghc ModSummary
fileModSummary :: String -> Ghc ModSummary
fileModSummary String
file = do
[ModSummary]
mss <- ModuleGraph -> [ModSummary]
mgModSummaries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m ModuleGraph
G.getModuleGraph
let xs :: [ModSummary]
xs = forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
m -> ModLocation -> Maybe String
G.ml_hs_file (ModSummary -> ModLocation
G.ms_location ModSummary
m) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
file) [ModSummary]
mss
case [ModSummary]
xs of
[ModSummary
ms] -> forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
[ModSummary]
_ -> forall a. HasCallStack => String -> a
error String
"fileModSummary"
withContext :: Ghc a -> Ghc a
withContext :: forall a. Ghc a -> Ghc a
withContext Ghc a
action = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket Ghc [InteractiveImport]
setup [InteractiveImport] -> Ghc ()
teardown forall {p}. p -> Ghc a
body
where
setup :: Ghc [InteractiveImport]
setup = forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
G.getContext
teardown :: [InteractiveImport] -> Ghc ()
teardown = [InteractiveImport] -> Ghc ()
setCtx
body :: p -> Ghc a
body p
_ = do
Ghc [InteractiveImport]
topImports forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [InteractiveImport] -> Ghc ()
setCtx
Ghc a
action
topImports :: Ghc [InteractiveImport]
topImports = do
[ModSummary]
mss <- ModuleGraph -> [ModSummary]
mgModSummaries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m ModuleGraph
G.getModuleGraph
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> InteractiveImport
modName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModSummary -> Ghc Bool
isTop [ModSummary]
mss
isTop :: ModSummary -> Ghc Bool
isTop ModSummary
mos = forall {m :: * -> *}. GhcMonad m => ModSummary -> m Bool
lookupMod ModSummary
mos forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Ghc Bool
returnFalse
lookupMod :: ModSummary -> m Bool
lookupMod ModSummary
mos = forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
G.lookupModule (ModSummary -> ModuleName
G.ms_mod_name ModSummary
mos) forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
returnFalse :: Ghc Bool
returnFalse = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
modName :: ModSummary -> InteractiveImport
modName = ModuleName -> InteractiveImport
G.IIModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
G.moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
G.ms_mod
setCtx :: [InteractiveImport] -> Ghc ()
setCtx = forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
G.setContext
getTypeLExpression :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type))
getTypeLExpression :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type))
getTypeLExpression TypecheckedModule
_ e :: LExpression
e@(L SrcSpanAnnA
spnA HsExpr GhcTc
_) = do
HscEnv
hs_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
G.getSession
(Messages DecoratedSDoc
_, Maybe CoreExpr
mbc) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> LExpression -> IO (Messages DecoratedSDoc, Maybe CoreExpr)
deSugarExpr HscEnv
hs_env LExpression
e
let spn :: SrcSpan
spn = forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
spnA
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (SrcSpan
spn, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CoreExpr
mbc
getTypeLBinding :: TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type))
getTypeLBinding :: TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type))
getTypeLBinding TypecheckedModule
_ (L SrcSpanAnnA
spnA FunBind{fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc LExpression
m}) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (SrcSpan
spn, Type
typ)
where
in_tys :: [Scaled Type]
in_tys = MatchGroupTc -> [Scaled Type]
mg_arg_tys forall a b. (a -> b) -> a -> b
$ forall p body. MatchGroup p body -> XMG p body
mg_ext MatchGroup GhcTc LExpression
m
out_typ :: Type
out_typ = MatchGroupTc -> Type
mg_res_ty forall a b. (a -> b) -> a -> b
$ forall p body. MatchGroup p body -> XMG p body
mg_ext MatchGroup GhcTc LExpression
m
typ :: Type
typ = [Scaled Type] -> Type -> Type
mkScaledFunctionTys [Scaled Type]
in_tys Type
out_typ
spn :: SrcSpan
spn = forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
spnA
getTypeLBinding TypecheckedModule
_ LBinding
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
getTypeLPattern :: TypecheckedModule -> LPattern -> Ghc (Maybe (SrcSpan, Type))
getTypeLPattern :: TypecheckedModule -> LPattern -> Ghc (Maybe (SrcSpan, Type))
getTypeLPattern TypecheckedModule
_ (L SrcSpanAnnA
spnA Pat GhcTc
pat) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
spnA, Pat GhcTc -> Type
hsPatType Pat GhcTc
pat)