Info.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TupleSections #-}

module Hhp.Info (
    infoExpr,
    info,
    typeExpr,
    types,
) where

import GHC (
    GenLocated (L),
    Ghc,
    LHsBind,
    LHsExpr,
    LPat,
    ModSummary,
    SrcSpan,
    Type,
    TypecheckedModule (..),
    mgModSummaries,
    mg_ext,
 )
import qualified GHC as G
import GHC.Core.Utils (exprType)
import GHC.Driver.Session (initSDocContext)
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 Control.Applicative ((<|>))
import Control.Monad (filterM)
import Control.Monad.Catch (SomeException (..), bracket, handle)
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O

import Hhp.Doc (getStyle, showOneLine, showPage)
import Hhp.GHCApi
import Hhp.Gap
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 opt cradle file expr = withGHC' $ do
    initializeFlagsWithCradle opt cradle
    info opt file expr

-- | Obtaining information of a target expression. (GHCi's info:)
info
    :: Options
    -> FilePath
    -- ^ A target file.
    -> Expression
    -- ^ A Haskell expression.
    -> Ghc String
info opt file expr = convert opt <$> handle handler body
  where
    body = inModuleContext file $ \ctx -> do
        sdoc <- infoThing expr
        return $ showPage ctx sdoc
    handler (SomeException _e) = return $ "Cannot show info: " ++ show _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 opt cradle file lineNo colNo = withGHC' $ do
    initializeFlagsWithCradle opt cradle
    types opt file lineNo 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 opt file lineNo colNo = convert opt <$> handle handler body
  where
    body = inModuleContext file $ \ctx -> do
        modSum <- fileModSummary file
        srcSpanTypes <- getSrcSpanType modSum lineNo colNo
        return $ map (toTup ctx) $ sortBy (cmp `on` fst) srcSpanTypes
    handler (SomeException _) = return []

type LExpression = LHsExpr GhcTc
type LBinding = LHsBind GhcTc
type LPattern = LPat GhcTc

getSrcSpanType :: 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 es = listifySpans tcs (lineNo, colNo) :: [LExpression]
        bs = listifySpans tcs (lineNo, colNo) :: [LBinding]
        ps = listifySpans tcs (lineNo, colNo) :: [LPattern]
    ets <- mapM (getTypeLExpression tcm) es
    bts <- mapM (getTypeLBinding tcm) bs
    pts <- mapM (getTypeLPattern tcm) ps
    return $ catMaybes $ concat [ets, bts, pts]

cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
    | a `G.isSubspanOf` b = O.LT
    | b `G.isSubspanOf` a = O.GT
    | otherwise = O.EQ

toTup :: SDocContext -> (SrcSpan, Type) -> ((Int, Int, Int, Int), String)
toTup ctx (spn, typ) = (fourInts spn, pretty ctx typ)

fourInts :: SrcSpan -> (Int, Int, Int, Int)
fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan

pretty :: SDocContext -> Type -> String
pretty ctx = showOneLine ctx . pprSigmaType

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

inModuleContext :: FilePath -> (SDocContext -> Ghc a) -> Ghc a
inModuleContext file action =
    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do
        setTargetFiles [file]
        withContext $ do
            dflag <- G.getSessionDynFlags
            style <- getStyle
            action $ initSDocContext dflag style

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

fileModSummary :: FilePath -> Ghc ModSummary
fileModSummary file = do
    mss <- mgModSummaries <$> G.getModuleGraph
    let xs = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss
    case xs of
        [ms] -> return ms
        _ -> error "fileModSummary"

withContext :: Ghc a -> Ghc a
withContext action = bracket setup teardown body
  where
    setup = G.getContext
    teardown = setCtx
    body _ = do
        topImports >>= setCtx
        action
    topImports = do
        mss <- mgModSummaries <$> G.getModuleGraph
        map modName <$> filterM isTop mss
    isTop mos = lookupMod mos <|> returnFalse
    lookupMod mos = G.lookupModule (G.ms_mod_name mos) Nothing >> return True
    returnFalse = return False
    modName = G.IIModule . G.moduleName . G.ms_mod
    setCtx = G.setContext

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

getTypeLExpression
    :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type))
getTypeLExpression _ e@(L spnA _) = do
    hs_env <- G.getSession
    (_, mbc) <- liftIO $ deSugarExpr hs_env e
    let spn = locA spnA
    return $ (spn,) . exprType <$> mbc

getTypeLBinding :: TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type))
getTypeLBinding _ (L spnA FunBind{fun_matches = m}) = return $ Just (spn, typ)
  where
    in_tys = mg_arg_tys $ mg_ext m
    out_typ = mg_res_ty $ mg_ext m
    typ = mkScaledFunctionTys in_tys out_typ
    spn = locA spnA
getTypeLBinding _ _ = return Nothing

getTypeLPattern :: TypecheckedModule -> LPattern -> Ghc (Maybe (SrcSpan, Type))
getTypeLPattern _ (L spnA pat) = return $ Just (locA spnA, hsPatType pat)