{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# OPTIONS_GHC -Wno-name-shadowing -Wno-compat-unqualified-imports #-}

-- | Get information on modules, expressions, and identifiers
module Clash.GHCi.UI.Info
    ( ModInfo(..)
    , SpanInfo(..)
    , spanInfoFromRealSrcSpan
    , collectInfo
    , findLoc
    , findNameUses
    , findType
    , getModInfo
    ) where

import           Control.Exception
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Maybe
import           Data.Data
import           Data.Function
import           Data.List
import           Data.Map.Strict   (Map)
import qualified Data.Map.Strict   as M
import           Data.Maybe
import           Data.Time
import           Prelude           hiding (mod,(<>))
import           System.Directory

import qualified CoreUtils
import           Desugar
import           DynFlags (HasDynFlags(..))
import           FastString
import           GHC
import           GhcMonad
import           Name
import           NameSet
import           Outputable
import           SrcLoc
import           TcHsSyn
import           Var

-- | Info about a module. This information is generated every time a
-- module is loaded.
data ModInfo = ModInfo
    { ModInfo -> ModSummary
modinfoSummary    :: !ModSummary
      -- ^ Summary generated by GHC. Can be used to access more
      -- information about the module.
    , ModInfo -> [SpanInfo]
modinfoSpans      :: [SpanInfo]
      -- ^ Generated set of information about all spans in the
      -- module that correspond to some kind of identifier for
      -- which there will be type info and/or location info.
    , ModInfo -> ModuleInfo
modinfoInfo       :: !ModuleInfo
      -- ^ Again, useful from GHC for accessing information
      -- (exports, instances, scope) from a module.
    , ModInfo -> UTCTime
modinfoLastUpdate :: !UTCTime
      -- ^ The timestamp of the file used to generate this record.
    }

-- | Type of some span of source code. Most of these fields are
-- unboxed but Haddock doesn't show that.
data SpanInfo = SpanInfo
    { SpanInfo -> RealSrcSpan
spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan
      -- ^ The span we associate information with
    , SpanInfo -> Maybe Type
spaninfoType      :: !(Maybe Type)
      -- ^ The 'Type' associated with the span
    , SpanInfo -> Maybe Id
spaninfoVar       :: !(Maybe Id)
      -- ^ The actual 'Var' associated with the span, if
      -- any. This can be useful for accessing a variety of
      -- information about the identifier such as module,
      -- locality, definition location, etc.
    }

instance Outputable SpanInfo where
  ppr :: SpanInfo -> SDoc
ppr (SpanInfo RealSrcSpan
s Maybe Type
t Maybe Id
i) = RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
s SDoc -> SDoc -> SDoc
<+> Maybe Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Type
t SDoc -> SDoc -> SDoc
<+> Maybe Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Id
i

-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
containsSpanInfo = RealSrcSpan -> RealSrcSpan -> Bool
containsSpan (RealSrcSpan -> RealSrcSpan -> Bool)
-> (SpanInfo -> RealSrcSpan) -> SpanInfo -> SpanInfo -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SpanInfo -> RealSrcSpan
spaninfoSrcSpan

-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
spaninfosWithin [SpanInfo]
spans' SpanInfo
si = (SpanInfo -> Bool) -> [SpanInfo] -> [SpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (SpanInfo
si SpanInfo -> SpanInfo -> Bool
`containsSpanInfo`) [SpanInfo]
spans'

-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
-- respectively)
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan RealSrcSpan
spn Maybe Type
mty Maybe Id
mvar =
    RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
SpanInfo RealSrcSpan
spn Maybe Type
mty Maybe Id
mvar

-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
-- only a 'RealSrcSpan'
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' RealSrcSpan
s = RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan RealSrcSpan
s Maybe Type
forall a. Maybe a
Nothing Maybe Id
forall a. Maybe a
Nothing

-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
srcSpanFilePath :: RealSrcSpan -> FilePath
srcSpanFilePath :: RealSrcSpan -> FilePath
srcSpanFilePath = FastString -> FilePath
unpackFS (FastString -> FilePath)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
srcSpanFile

-- | Try to find the location of the given identifier at the given
-- position in the module.
findLoc :: GhcMonad m
        => Map ModuleName ModInfo
        -> RealSrcSpan
        -> String
        -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
findLoc :: Map ModuleName ModInfo
-> RealSrcSpan
-> FilePath
-> ExceptT SDoc m (ModInfo, Name, SrcSpan)
findLoc Map ModuleName ModInfo
infos RealSrcSpan
span0 FilePath
string = do
    ModuleName
name  <- SDoc -> MaybeT m ModuleName -> ExceptT SDoc m ModuleName
forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT SDoc
"Couldn't guess that module name. Does it exist?" (MaybeT m ModuleName -> ExceptT SDoc m ModuleName)
-> MaybeT m ModuleName -> ExceptT SDoc m ModuleName
forall a b. (a -> b) -> a -> b
$
             Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule Map ModuleName ModInfo
infos (RealSrcSpan -> FilePath
srcSpanFilePath RealSrcSpan
span0)

    ModInfo
info  <- SDoc -> MaybeT m ModInfo -> ExceptT SDoc m ModInfo
forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT SDoc
"No module info for current file! Try loading it?" (MaybeT m ModInfo -> ExceptT SDoc m ModInfo)
-> MaybeT m ModInfo -> ExceptT SDoc m ModInfo
forall a b. (a -> b) -> a -> b
$
             m (Maybe ModInfo) -> MaybeT m ModInfo
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ModInfo) -> MaybeT m ModInfo)
-> m (Maybe ModInfo) -> MaybeT m ModInfo
forall a b. (a -> b) -> a -> b
$ Maybe ModInfo -> m (Maybe ModInfo)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ModInfo -> m (Maybe ModInfo))
-> Maybe ModInfo -> m (Maybe ModInfo)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Map ModuleName ModInfo -> Maybe ModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
name Map ModuleName ModInfo
infos

    Name
name' <- Map ModuleName ModInfo
-> RealSrcSpan -> ModInfo -> FilePath -> ExceptT SDoc m Name
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> ModInfo -> FilePath -> ExceptT SDoc m Name
findName Map ModuleName ModInfo
infos RealSrcSpan
span0 ModInfo
info FilePath
string

    case Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name' of
        UnhelpfulSpan{} -> do
            SDoc -> ExceptT SDoc m (ModInfo, Name, SrcSpan)
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (SDoc
"Found a name, but no location information." SDoc -> SDoc -> SDoc
<+>
                    SDoc
"The module is:" SDoc -> SDoc -> SDoc
<+>
                    SDoc -> (Module -> SDoc) -> Maybe Module -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
"<unknown>" (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> (Module -> ModuleName) -> Module -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName)
                          (Name -> Maybe Module
nameModule_maybe Name
name'))

        SrcSpan
span' -> (ModInfo, Name, SrcSpan) -> ExceptT SDoc m (ModInfo, Name, SrcSpan)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModInfo
info,Name
name',SrcSpan
span')

-- | Find any uses of the given identifier in the codebase.
findNameUses :: (GhcMonad m)
             => Map ModuleName ModInfo
             -> RealSrcSpan
             -> String
             -> ExceptT SDoc m [SrcSpan]
findNameUses :: Map ModuleName ModInfo
-> RealSrcSpan -> FilePath -> ExceptT SDoc m [SrcSpan]
findNameUses Map ModuleName ModInfo
infos RealSrcSpan
span0 FilePath
string =
    (ModInfo, Name, SrcSpan) -> [SrcSpan]
locToSpans ((ModInfo, Name, SrcSpan) -> [SrcSpan])
-> ExceptT SDoc m (ModInfo, Name, SrcSpan)
-> ExceptT SDoc m [SrcSpan]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ModuleName ModInfo
-> RealSrcSpan
-> FilePath
-> ExceptT SDoc m (ModInfo, Name, SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan
-> FilePath
-> ExceptT SDoc m (ModInfo, Name, SrcSpan)
findLoc Map ModuleName ModInfo
infos RealSrcSpan
span0 FilePath
string
  where
    locToSpans :: (ModInfo, Name, SrcSpan) -> [SrcSpan]
locToSpans (ModInfo
modinfo,Name
name',SrcSpan
span') =
        [SrcSpan] -> [SrcSpan]
stripSurrounding (SrcSpan
span' SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: (SpanInfo -> SrcSpan) -> [SpanInfo] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map SpanInfo -> SrcSpan
toSrcSpan [SpanInfo]
spans)
      where
        toSrcSpan :: SpanInfo -> SrcSpan
toSrcSpan = RealSrcSpan -> SrcSpan
RealSrcSpan (RealSrcSpan -> SrcSpan)
-> (SpanInfo -> RealSrcSpan) -> SpanInfo -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> RealSrcSpan
spaninfoSrcSpan
        spans :: [SpanInfo]
spans = (SpanInfo -> Bool) -> [SpanInfo] -> [SpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name') (Maybe Name -> Bool)
-> (SpanInfo -> Maybe Name) -> SpanInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> Name) -> Maybe Id -> Maybe Name
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Name
forall a. NamedThing a => a -> Name
getName (Maybe Id -> Maybe Name)
-> (SpanInfo -> Maybe Id) -> SpanInfo -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> Maybe Id
spaninfoVar)
                       (ModInfo -> [SpanInfo]
modinfoSpans ModInfo
modinfo)

-- | Filter out redundant spans which surround/contain other spans.
stripSurrounding :: [SrcSpan] -> [SrcSpan]
stripSurrounding :: [SrcSpan] -> [SrcSpan]
stripSurrounding [SrcSpan]
xs = (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SrcSpan -> Bool) -> SrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Bool
isRedundant) [SrcSpan]
xs
  where
    isRedundant :: SrcSpan -> Bool
isRedundant SrcSpan
x = (SrcSpan -> Bool) -> [SrcSpan] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (SrcSpan
x SrcSpan -> SrcSpan -> Bool
`strictlyContains`) [SrcSpan]
xs

    (RealSrcSpan RealSrcSpan
s1) strictlyContains :: SrcSpan -> SrcSpan -> Bool
`strictlyContains` (RealSrcSpan RealSrcSpan
s2)
         = RealSrcSpan
s1 RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan
s2 Bool -> Bool -> Bool
&& RealSrcSpan
s1 RealSrcSpan -> RealSrcSpan -> Bool
`containsSpan` RealSrcSpan
s2
    SrcSpan
_                `strictlyContains` SrcSpan
_ = Bool
False

-- | Try to resolve the name located at the given position, or
-- otherwise resolve based on the current module's scope.
findName :: GhcMonad m
         => Map ModuleName ModInfo
         -> RealSrcSpan
         -> ModInfo
         -> String
         -> ExceptT SDoc m Name
findName :: Map ModuleName ModInfo
-> RealSrcSpan -> ModInfo -> FilePath -> ExceptT SDoc m Name
findName Map ModuleName ModInfo
infos RealSrcSpan
span0 ModInfo
mi FilePath
string =
    case [SpanInfo] -> SpanInfo -> Maybe Id
resolveName (ModInfo -> [SpanInfo]
modinfoSpans ModInfo
mi) (RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' RealSrcSpan
span0) of
      Maybe Id
Nothing -> ExceptT SDoc m Name
tryExternalModuleResolution
      Just Id
name ->
        case Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
name of
          UnhelpfulSpan {} -> ExceptT SDoc m Name
tryExternalModuleResolution
          RealSrcSpan   {} -> Name -> ExceptT SDoc m Name
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
name)
  where
    tryExternalModuleResolution :: ExceptT SDoc m Name
tryExternalModuleResolution =
      case (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (FastString -> Name -> Bool
matchName (FastString -> Name -> Bool) -> FastString -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FastString
mkFastString FilePath
string)
                ([Name] -> Maybe [Name] -> [Name]
forall a. a -> Maybe a -> a
fromMaybe [] (ModuleInfo -> Maybe [Name]
modInfoTopLevelScope (ModInfo -> ModuleInfo
modinfoInfo ModInfo
mi))) of
        Maybe Name
Nothing -> SDoc -> ExceptT SDoc m Name
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE SDoc
"Couldn't resolve to any modules."
        Just Name
imported -> Map ModuleName ModInfo -> Name -> ExceptT SDoc m Name
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo -> Name -> ExceptT SDoc m Name
resolveNameFromModule Map ModuleName ModInfo
infos Name
imported

    matchName :: FastString -> Name -> Bool
    matchName :: FastString -> Name -> Bool
matchName FastString
str Name
name =
      FastString
str FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
==
      OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name)

-- | Try to resolve the name from another (loaded) module's exports.
resolveNameFromModule :: GhcMonad m
                      => Map ModuleName ModInfo
                      -> Name
                      -> ExceptT SDoc m Name
resolveNameFromModule :: Map ModuleName ModInfo -> Name -> ExceptT SDoc m Name
resolveNameFromModule Map ModuleName ModInfo
infos Name
name = do
     Module
modL <- ExceptT SDoc m Module
-> (Module -> ExceptT SDoc m Module)
-> Maybe Module
-> ExceptT SDoc m Module
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDoc -> ExceptT SDoc m Module
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (SDoc -> ExceptT SDoc m Module) -> SDoc -> ExceptT SDoc m Module
forall a b. (a -> b) -> a -> b
$ SDoc
"No module for" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) Module -> ExceptT SDoc m Module
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Module -> ExceptT SDoc m Module)
-> Maybe Module -> ExceptT SDoc m Module
forall a b. (a -> b) -> a -> b
$
             Name -> Maybe Module
nameModule_maybe Name
name

     ModInfo
info <- ExceptT SDoc m ModInfo
-> (ModInfo -> ExceptT SDoc m ModInfo)
-> Maybe ModInfo
-> ExceptT SDoc m ModInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDoc -> ExceptT SDoc m ModInfo
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> UnitId
moduleUnitId Module
modL) SDoc -> SDoc -> SDoc
<> SDoc
":" SDoc -> SDoc -> SDoc
<>
                            Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
modL)) ModInfo -> ExceptT SDoc m ModInfo
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe ModInfo -> ExceptT SDoc m ModInfo)
-> Maybe ModInfo -> ExceptT SDoc m ModInfo
forall a b. (a -> b) -> a -> b
$
             ModuleName -> Map ModuleName ModInfo -> Maybe ModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Module -> ModuleName
moduleName Module
modL) Map ModuleName ModInfo
infos

     ExceptT SDoc m Name
-> (Name -> ExceptT SDoc m Name)
-> Maybe Name
-> ExceptT SDoc m Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDoc -> ExceptT SDoc m Name
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE SDoc
"No matching export in any local modules.") Name -> ExceptT SDoc m Name
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Name -> ExceptT SDoc m Name)
-> Maybe Name -> ExceptT SDoc m Name
forall a b. (a -> b) -> a -> b
$
         (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (Name -> Name -> Bool
matchName Name
name) (ModuleInfo -> [Name]
modInfoExports (ModInfo -> ModuleInfo
modinfoInfo ModInfo
info))
  where
    matchName :: Name -> Name -> Bool
    matchName :: Name -> Name -> Bool
matchName Name
x Name
y = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
x) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
==
                    OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
y)

-- | Try to resolve the type display from the given span.
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Id
resolveName [SpanInfo]
spans' SpanInfo
si = [Id] -> Maybe Id
forall a. [a] -> Maybe a
listToMaybe ([Id] -> Maybe Id) -> [Id] -> Maybe Id
forall a b. (a -> b) -> a -> b
$ (SpanInfo -> Maybe Id) -> [SpanInfo] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpanInfo -> Maybe Id
spaninfoVar ([SpanInfo] -> [Id]) -> [SpanInfo] -> [Id]
forall a b. (a -> b) -> a -> b
$
                        [SpanInfo] -> [SpanInfo]
forall a. [a] -> [a]
reverse [SpanInfo]
spans' [SpanInfo] -> SpanInfo -> [SpanInfo]
`spaninfosWithin` SpanInfo
si

-- | Try to find the type of the given span.
findType :: GhcMonad m
         => Map ModuleName ModInfo
         -> RealSrcSpan
         -> String
         -> ExceptT SDoc m (ModInfo, Type)
findType :: Map ModuleName ModInfo
-> RealSrcSpan -> FilePath -> ExceptT SDoc m (ModInfo, Type)
findType Map ModuleName ModInfo
infos RealSrcSpan
span0 FilePath
string = do
    ModuleName
name  <- SDoc -> MaybeT m ModuleName -> ExceptT SDoc m ModuleName
forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT SDoc
"Couldn't guess that module name. Does it exist?" (MaybeT m ModuleName -> ExceptT SDoc m ModuleName)
-> MaybeT m ModuleName -> ExceptT SDoc m ModuleName
forall a b. (a -> b) -> a -> b
$
             Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule Map ModuleName ModInfo
infos (RealSrcSpan -> FilePath
srcSpanFilePath RealSrcSpan
span0)

    ModInfo
info  <- SDoc -> MaybeT m ModInfo -> ExceptT SDoc m ModInfo
forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT SDoc
"No module info for current file! Try loading it?" (MaybeT m ModInfo -> ExceptT SDoc m ModInfo)
-> MaybeT m ModInfo -> ExceptT SDoc m ModInfo
forall a b. (a -> b) -> a -> b
$
             m (Maybe ModInfo) -> MaybeT m ModInfo
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ModInfo) -> MaybeT m ModInfo)
-> m (Maybe ModInfo) -> MaybeT m ModInfo
forall a b. (a -> b) -> a -> b
$ Maybe ModInfo -> m (Maybe ModInfo)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ModInfo -> m (Maybe ModInfo))
-> Maybe ModInfo -> m (Maybe ModInfo)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Map ModuleName ModInfo -> Maybe ModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
name Map ModuleName ModInfo
infos

    case [SpanInfo] -> SpanInfo -> Maybe Type
resolveType (ModInfo -> [SpanInfo]
modinfoSpans ModInfo
info) (RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' RealSrcSpan
span0) of
        Maybe Type
Nothing -> (,) ModInfo
info (Type -> (ModInfo, Type))
-> ExceptT SDoc m Type -> ExceptT SDoc m (ModInfo, Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m Type -> ExceptT SDoc m Type
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRnExprMode -> FilePath -> m Type
forall (m :: Type -> Type).
GhcMonad m =>
TcRnExprMode -> FilePath -> m Type
exprType TcRnExprMode
TM_Inst FilePath
string)
        Just Type
ty -> (ModInfo, Type) -> ExceptT SDoc m (ModInfo, Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModInfo
info, Type
ty)
  where
    -- | Try to resolve the type display from the given span.
    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
resolveType [SpanInfo]
spans' SpanInfo
si = [Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe ([Type] -> Maybe Type) -> [Type] -> Maybe Type
forall a b. (a -> b) -> a -> b
$ (SpanInfo -> Maybe Type) -> [SpanInfo] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpanInfo -> Maybe Type
spaninfoType ([SpanInfo] -> [Type]) -> [SpanInfo] -> [Type]
forall a b. (a -> b) -> a -> b
$
                            [SpanInfo] -> [SpanInfo]
forall a. [a] -> [a]
reverse [SpanInfo]
spans' [SpanInfo] -> SpanInfo -> [SpanInfo]
`spaninfosWithin` SpanInfo
si

-- | Guess a module name from a file path.
guessModule :: GhcMonad m
            => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule :: Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule Map ModuleName ModInfo
infos FilePath
fp = do
    Target
target <- m Target -> MaybeT m Target
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Target -> MaybeT m Target) -> m Target -> MaybeT m Target
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
guessTarget FilePath
fp Maybe Phase
forall a. Maybe a
Nothing
    case Target -> TargetId
targetId Target
target of
        TargetModule ModuleName
mn  -> ModuleName -> MaybeT m ModuleName
forall (m :: Type -> Type) a. Monad m => a -> m a
return ModuleName
mn
        TargetFile FilePath
fp' Maybe Phase
_ -> FilePath -> MaybeT m ModuleName
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> MaybeT m ModuleName
guessModule' FilePath
fp'
  where
    guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
    guessModule' :: FilePath -> MaybeT m ModuleName
guessModule' FilePath
fp' = case FilePath -> Maybe ModuleName
findModByFp FilePath
fp' of
        Just ModuleName
mn -> ModuleName -> MaybeT m ModuleName
forall (m :: Type -> Type) a. Monad m => a -> m a
return ModuleName
mn
        Maybe ModuleName
Nothing -> do
            FilePath
fp'' <- IO FilePath -> MaybeT m FilePath
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
makeRelativeToCurrentDirectory FilePath
fp')

            Target
target' <- m Target -> MaybeT m Target
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Target -> MaybeT m Target) -> m Target -> MaybeT m Target
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
guessTarget FilePath
fp'' Maybe Phase
forall a. Maybe a
Nothing
            case Target -> TargetId
targetId Target
target' of
                TargetModule ModuleName
mn -> ModuleName -> MaybeT m ModuleName
forall (m :: Type -> Type) a. Monad m => a -> m a
return ModuleName
mn
                TargetId
_               -> m (Maybe ModuleName) -> MaybeT m ModuleName
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ModuleName) -> MaybeT m ModuleName)
-> (Maybe ModuleName -> m (Maybe ModuleName))
-> Maybe ModuleName
-> MaybeT m ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ModuleName -> m (Maybe ModuleName)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ModuleName -> MaybeT m ModuleName)
-> Maybe ModuleName -> MaybeT m ModuleName
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe ModuleName
findModByFp FilePath
fp''

    findModByFp :: FilePath -> Maybe ModuleName
    findModByFp :: FilePath -> Maybe ModuleName
findModByFp FilePath
fp' = (ModuleName, ModInfo) -> ModuleName
forall a b. (a, b) -> a
fst ((ModuleName, ModInfo) -> ModuleName)
-> Maybe (ModuleName, ModInfo) -> Maybe ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ModuleName, ModInfo) -> Bool)
-> [(ModuleName, ModInfo)] -> Maybe (ModuleName, ModInfo)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp' Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe FilePath -> Bool)
-> ((ModuleName, ModInfo) -> Maybe FilePath)
-> (ModuleName, ModInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, ModInfo) -> Maybe FilePath
mifp) (Map ModuleName ModInfo -> [(ModuleName, ModInfo)]
forall k a. Map k a -> [(k, a)]
M.toList Map ModuleName ModInfo
infos)
      where
        mifp :: (ModuleName, ModInfo) -> Maybe FilePath
        mifp :: (ModuleName, ModInfo) -> Maybe FilePath
mifp = ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath)
-> ((ModuleName, ModInfo) -> ModLocation)
-> (ModuleName, ModInfo)
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation)
-> ((ModuleName, ModInfo) -> ModSummary)
-> (ModuleName, ModInfo)
-> ModLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModInfo -> ModSummary
modinfoSummary (ModInfo -> ModSummary)
-> ((ModuleName, ModInfo) -> ModInfo)
-> (ModuleName, ModInfo)
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, ModInfo) -> ModInfo
forall a b. (a, b) -> b
snd


-- | Collect type info data for the loaded modules.
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
               -> m (Map ModuleName ModInfo)
collectInfo :: Map ModuleName ModInfo
-> [ModuleName] -> m (Map ModuleName ModInfo)
collectInfo Map ModuleName ModInfo
ms [ModuleName]
loaded = do
    DynFlags
df <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    IO [ModuleName] -> m [ModuleName]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ((ModuleName -> IO Bool) -> [ModuleName] -> IO [ModuleName]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleName -> IO Bool
cacheInvalid [ModuleName]
loaded) m [ModuleName]
-> ([ModuleName] -> m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> Map ModuleName ModInfo -> m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map ModuleName ModInfo
ms
        [ModuleName]
invalidated -> do
            IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ()
putStrLn (FilePath
"Collecting type info for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                              Int -> FilePath
forall a. Show a => a -> FilePath
show ([ModuleName] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ModuleName]
invalidated) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                              FilePath
" module(s) ... "))

            (Map ModuleName ModInfo
 -> ModuleName -> m (Map ModuleName ModInfo))
-> Map ModuleName ModInfo
-> [ModuleName]
-> m (Map ModuleName ModInfo)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DynFlags
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
go DynFlags
df) Map ModuleName ModInfo
ms [ModuleName]
invalidated
  where
    go :: DynFlags
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
go DynFlags
df Map ModuleName ModInfo
m ModuleName
name = do { ModInfo
info <- ModuleName -> m ModInfo
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m ModInfo
getModInfo ModuleName
name; Map ModuleName ModInfo -> m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModuleName
-> ModInfo -> Map ModuleName ModInfo -> Map ModuleName ModInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleName
name ModInfo
info Map ModuleName ModInfo
m) }
                   m (Map ModuleName ModInfo)
-> (SomeException -> m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`gcatch`
                   (\(SomeException
e :: SomeException) -> do
                         IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn
                                (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> PrintUnqualified -> SDoc -> FilePath
showSDocForUser DynFlags
df PrintUnqualified
alwaysQualify
                                (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ SDoc
"Error while getting type info from" SDoc -> SDoc -> SDoc
<+>
                                  ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
name SDoc -> SDoc -> SDoc
<> SDoc
":" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
                         Map ModuleName ModInfo -> m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map ModuleName ModInfo
m)

    cacheInvalid :: ModuleName -> IO Bool
cacheInvalid ModuleName
name = case ModuleName -> Map ModuleName ModInfo -> Maybe ModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
name Map ModuleName ModInfo
ms of
        Maybe ModInfo
Nothing -> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
        Just ModInfo
mi -> do
            let fp :: FilePath
fp = ModSummary -> FilePath
srcFilePath (ModInfo -> ModSummary
modinfoSummary ModInfo
mi)
                last' :: UTCTime
last' = ModInfo -> UTCTime
modinfoLastUpdate ModInfo
mi
            UTCTime
current <- FilePath -> IO UTCTime
getModificationTime FilePath
fp
            Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fp
            if Bool
exists
                then Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ UTCTime
current UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= UTCTime
last'
                else Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True

-- | Get the source file path from a ModSummary.
-- If the .hs file is missing, and the .o file exists,
-- we return the .o file path.
srcFilePath :: ModSummary -> FilePath
srcFilePath :: ModSummary -> FilePath
srcFilePath ModSummary
modSum = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
obj_fp Maybe FilePath
src_fp
    where
        src_fp :: Maybe FilePath
src_fp = ModLocation -> Maybe FilePath
ml_hs_file ModLocation
ms_loc
        obj_fp :: FilePath
obj_fp = ModLocation -> FilePath
ml_obj_file ModLocation
ms_loc
        ms_loc :: ModLocation
ms_loc = ModSummary -> ModLocation
ms_location ModSummary
modSum

-- | Get info about the module: summary, types, etc.
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo :: ModuleName -> m ModInfo
getModInfo ModuleName
name = do
    ModSummary
m <- ModuleName -> m ModSummary
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m ModSummary
getModSummary ModuleName
name
    ParsedModule
p <- ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
parseModule ModSummary
m
    TypecheckedModule
typechecked <- ParsedModule -> m TypecheckedModule
forall (m :: Type -> Type).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
p
    [SpanInfo]
allTypes <- TypecheckedModule -> m [SpanInfo]
forall (m :: Type -> Type).
GhcMonad m =>
TypecheckedModule -> m [SpanInfo]
processAllTypeCheckedModule TypecheckedModule
typechecked
    let i :: ModuleInfo
i = TypecheckedModule -> ModuleInfo
tm_checked_module_info TypecheckedModule
typechecked
    UTCTime
ts <- IO UTCTime -> m UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> m UTCTime) -> IO UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationTime (FilePath -> IO UTCTime) -> FilePath -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ ModSummary -> FilePath
srcFilePath ModSummary
m
    ModInfo -> m ModInfo
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModSummary -> [SpanInfo] -> ModuleInfo -> UTCTime -> ModInfo
ModInfo ModSummary
m [SpanInfo]
allTypes ModuleInfo
i UTCTime
ts)

-- | Get ALL source spans in the module.
processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
                            -> m [SpanInfo]
processAllTypeCheckedModule :: TypecheckedModule -> m [SpanInfo]
processAllTypeCheckedModule TypecheckedModule
tcm = do
    [Maybe (Maybe Id, SrcSpan, Type)]
bts <- (LHsBind GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type)))
-> [LHsBind GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsBind GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLHsBind ([LHsBind GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)])
-> [LHsBind GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [LHsBind GhcTc]
forall a. (HasSrcSpan a, Typeable a) => TypecheckedSource -> [a]
listifyAllSpans TypecheckedSource
tcs
    [Maybe (Maybe Id, SrcSpan, Type)]
ets <- (LHsExpr GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type)))
-> [LHsExpr GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLHsExpr ([LHsExpr GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)])
-> [LHsExpr GhcTc] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [LHsExpr GhcTc]
forall a. (HasSrcSpan a, Typeable a) => TypecheckedSource -> [a]
listifyAllSpans TypecheckedSource
tcs
    [Maybe (Maybe Id, SrcSpan, Type)]
pts <- (Located (Pat GhcTc) -> m (Maybe (Maybe Id, SrcSpan, Type)))
-> [Located (Pat GhcTc)] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
Located (Pat GhcTc) -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLPat    ([Located (Pat GhcTc)] -> m [Maybe (Maybe Id, SrcSpan, Type)])
-> [Located (Pat GhcTc)] -> m [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [Located (Pat GhcTc)]
forall a. (HasSrcSpan a, Typeable a) => TypecheckedSource -> [a]
listifyAllSpans TypecheckedSource
tcs
    [SpanInfo] -> m [SpanInfo]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([SpanInfo] -> m [SpanInfo]) -> [SpanInfo] -> m [SpanInfo]
forall a b. (a -> b) -> a -> b
$ ((Maybe Id, SrcSpan, Type) -> Maybe SpanInfo)
-> [(Maybe Id, SrcSpan, Type)] -> [SpanInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Id, SrcSpan, Type) -> Maybe SpanInfo
toSpanInfo
           ([(Maybe Id, SrcSpan, Type)] -> [SpanInfo])
-> [(Maybe Id, SrcSpan, Type)] -> [SpanInfo]
forall a b. (a -> b) -> a -> b
$ ((Maybe Id, SrcSpan, Type)
 -> (Maybe Id, SrcSpan, Type) -> Ordering)
-> [(Maybe Id, SrcSpan, Type)] -> [(Maybe Id, SrcSpan, Type)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Maybe Id, SrcSpan, Type) -> (Maybe Id, SrcSpan, Type) -> Ordering
forall a c a c. (a, SrcSpan, c) -> (a, SrcSpan, c) -> Ordering
cmpSpan
           ([(Maybe Id, SrcSpan, Type)] -> [(Maybe Id, SrcSpan, Type)])
-> [(Maybe Id, SrcSpan, Type)] -> [(Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ [Maybe (Maybe Id, SrcSpan, Type)] -> [(Maybe Id, SrcSpan, Type)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Maybe Id, SrcSpan, Type)]
bts [Maybe (Maybe Id, SrcSpan, Type)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
forall a. [a] -> [a] -> [a]
++ [Maybe (Maybe Id, SrcSpan, Type)]
ets [Maybe (Maybe Id, SrcSpan, Type)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
forall a. [a] -> [a] -> [a]
++ [Maybe (Maybe Id, SrcSpan, Type)]
pts)
  where
    tcs :: TypecheckedSource
tcs = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
tcm

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLHsBind (LHsBind GhcTc -> Located (SrcSpanLess (LHsBind GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
        = Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Maybe Id, SrcSpan, Type)
 -> m (Maybe (Maybe Id, SrcSpan, Type)))
-> Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall a b. (a -> b) -> a -> b
$ (Maybe Id, SrcSpan, Type) -> Maybe (Maybe Id, SrcSpan, Type)
forall a. a -> Maybe a
Just (Id -> Maybe Id
forall a. a -> Maybe a
Just (Located Id -> SrcSpanLess (Located Id)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Id
pid),Located Id -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (IdP GhcTc)
Located Id
pid,Id -> Type
varType (Located Id -> SrcSpanLess (Located Id)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Id
pid))
    getTypeLHsBind LHsBind GhcTc
_ = Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Maybe Id, SrcSpan, Type)
forall a. Maybe a
Nothing

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLHsExpr LHsExpr GhcTc
e = do
        HscEnv
hs_env  <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
        (Messages
_,Maybe CoreExpr
mbe) <- IO (Messages, Maybe CoreExpr) -> m (Messages, Maybe CoreExpr)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe CoreExpr) -> m (Messages, Maybe CoreExpr))
-> IO (Messages, Maybe CoreExpr) -> m (Messages, Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$ HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
deSugarExpr HscEnv
hs_env LHsExpr GhcTc
e
        Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Maybe Id, SrcSpan, Type)
 -> m (Maybe (Maybe Id, SrcSpan, Type)))
-> Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> (Maybe Id, SrcSpan, Type))
-> Maybe CoreExpr -> Maybe (Maybe Id, SrcSpan, Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CoreExpr
expr -> (Maybe Id
mid, LHsExpr GhcTc -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcTc
e, CoreExpr -> Type
CoreUtils.exprType CoreExpr
expr)) Maybe CoreExpr
mbe
      where
        mid :: Maybe Id
        mid :: Maybe Id
mid | HsVar XVar GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located Id))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Id)
i) <- HsExpr GhcTc -> HsExpr GhcTc
forall p. HsExpr p -> HsExpr p
unwrapVar (LHsExpr GhcTc -> SrcSpanLess (LHsExpr GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTc
e) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
SrcSpanLess (Located Id)
i
            | Bool
otherwise                                  = Maybe Id
forall a. Maybe a
Nothing

        unwrapVar :: HsExpr p -> HsExpr p
unwrapVar (HsWrap XWrap p
_ HsWrapper
_ HsExpr p
var) = HsExpr p
var
        unwrapVar HsExpr p
e'               = HsExpr p
e'

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id, SrcSpan, Type))
getTypeLPat (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
spn SrcSpanLess (Located (Pat GhcTc))
pat) =
        Maybe (Maybe Id, SrcSpan, Type)
-> m (Maybe (Maybe Id, SrcSpan, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Maybe Id, SrcSpan, Type) -> Maybe (Maybe Id, SrcSpan, Type)
forall a. a -> Maybe a
Just (Pat GhcTc -> Maybe (IdP GhcTc)
forall p. Pat p -> Maybe (IdP p)
getMaybeId Pat GhcTc
SrcSpanLess (Located (Pat GhcTc))
pat,SrcSpan
spn,Pat GhcTc -> Type
hsPatType Pat GhcTc
SrcSpanLess (Located (Pat GhcTc))
pat))
      where
        getMaybeId :: Pat p -> Maybe (IdP p)
getMaybeId (VarPat XVarPat p
_ (Located (IdP p) -> Located (SrcSpanLess (Located (IdP p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (IdP p))
vid)) = IdP p -> Maybe (IdP p)
forall a. a -> Maybe a
Just IdP p
SrcSpanLess (Located (IdP p))
vid
        getMaybeId Pat p
_                        = Maybe (IdP p)
forall a. Maybe a
Nothing

    -- | Get ALL source spans in the source.
    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
    listifyAllSpans :: TypecheckedSource -> [a]
listifyAllSpans = ([a] -> [a] -> [a]) -> [a] -> GenericQ [a] -> GenericQ [a]
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [] ([] [a] -> (a -> [a]) -> a -> [a]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\a
x -> [a
x | a -> Bool
forall a. HasSrcSpan a => a -> Bool
p a
x]))
      where
        p :: a -> Bool
p (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
spn SrcSpanLess a
_) = SrcSpan -> Bool
isGoodSrcSpan SrcSpan
spn

    -- | Variant of @syb@'s @everything@ (which summarises all nodes
    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans r -> r -> r
k r
z GenericQ r
f a
x
      | (Bool
False Bool -> (NameSet -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (Bool -> NameSet -> Bool
forall a b. a -> b -> a
const Bool
True :: NameSet -> Bool)) a
x = r
z
      | Bool
otherwise = (r -> r -> r) -> r -> [r] -> r
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k (a -> r
GenericQ r
f a
x) (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((r -> r -> r) -> r -> GenericQ r -> GenericQ r
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans r -> r -> r
k r
z GenericQ r
f) a
x)

    cmpSpan :: (a, SrcSpan, c) -> (a, SrcSpan, c) -> Ordering
cmpSpan (a
_,SrcSpan
a,c
_) (a
_,SrcSpan
b,c
_)
      | SrcSpan
a SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
b = Ordering
LT
      | SrcSpan
b SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
a = Ordering
GT
      | Bool
otherwise         = Ordering
EQ

    -- | Pretty print the types into a 'SpanInfo'.
    toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
    toSpanInfo :: (Maybe Id, SrcSpan, Type) -> Maybe SpanInfo
toSpanInfo (Maybe Id
n,RealSrcSpan RealSrcSpan
spn,Type
typ)
        = SpanInfo -> Maybe SpanInfo
forall a. a -> Maybe a
Just (SpanInfo -> Maybe SpanInfo) -> SpanInfo -> Maybe SpanInfo
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan RealSrcSpan
spn (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ) Maybe Id
n
    toSpanInfo (Maybe Id, SrcSpan, Type)
_ = Maybe SpanInfo
forall a. Maybe a
Nothing

-- helper stolen from @syb@ package
type GenericQ r = forall a. Data a => a -> r

mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
(r
r mkQ :: r -> (b -> r) -> a -> r
`mkQ` b -> r
br) a
a = r -> (b -> r) -> Maybe b -> r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe r
r b -> r
br (a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a)