{-# 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

----------------------------------------------------------------

-- | Obtaining information of a target expression. (GHCi's info:)
infoExpr :: Options
         -> Cradle
         -> FilePath     -- ^ A target file.
         -> Expression   -- ^ A Haskell 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

-- | Obtaining information of a target expression. (GHCi's info:)
info :: Options
     -> FilePath     -- ^ A target file.
     -> Expression   -- ^ A Haskell 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

----------------------------------------------------------------

-- | Obtaining type of a target expression. (GHCi's type:)
typeExpr :: Options
         -> Cradle
         -> FilePath     -- ^ A target file.
         -> Int          -- ^ Line number.
         -> Int          -- ^ Column number.
         -> 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

-- | Obtaining type of a target expression. (GHCi's type:)
types :: Options
      -> FilePath     -- ^ A target file.
      -> Int          -- ^ Line number.
      -> Int          -- ^ Column number.
      -> 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)