{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
module Clash.GHCi.UI.Info
( ModInfo(..)
, SpanInfo(..)
, spanInfoFromRealSrcSpan
, collectInfo
, findLoc
, findNameUses
, findType
, getModInfo
) where
import Control.Exception
import Control.Monad
import Control.Monad.Catch as MC
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Data
import Data.Function
import Data.List (find, sortBy)
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 GHC.Hs.Syn.Type
import GHC.Driver.Session (HasDynFlags(..))
import GHC.Data.FastString
import GHC
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Types.Var
import qualified GHC.Data.Strict as Strict
data ModInfo = ModInfo
{ ModInfo -> ModSummary
modinfoSummary :: !ModSummary
, ModInfo -> [SpanInfo]
modinfoSpans :: [SpanInfo]
, ModInfo -> ModuleInfo
modinfoInfo :: !ModuleInfo
, ModInfo -> UTCTime
modinfoLastUpdate :: !UTCTime
}
data SpanInfo = SpanInfo
{ SpanInfo -> RealSrcSpan
spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan
, SpanInfo -> Maybe Type
spaninfoType :: !(Maybe Type)
, SpanInfo -> Maybe Id
spaninfoVar :: !(Maybe Id)
}
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
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Type
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Id
i
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
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'
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
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
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
findLoc :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo,Name,SrcSpan)
findLoc :: 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 = 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 a. a -> m a
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
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc
"The module is:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> (GenModule Unit -> SDoc) -> Maybe (GenModule Unit) -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
"<unknown>" (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName)
(Name -> Maybe (GenModule Unit)
nameModule_maybe Name
name'))
SrcSpan
span' -> (ModInfo, Name, SrcSpan) -> ExceptT SDoc m (ModInfo, Name, SrcSpan)
forall a. a -> ExceptT SDoc m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModInfo
info,Name
name',SrcSpan
span')
findNameUses :: (GhcMonad m)
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m [SrcSpan]
findNameUses :: forall (m :: Type -> Type).
GhcMonad m =>
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 SpanInfo
s = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (SpanInfo -> RealSrcSpan
spaninfoSrcSpan SpanInfo
s) Maybe BufSpan
forall a. Maybe a
Strict.Nothing
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 a b. (a -> b) -> Maybe a -> Maybe b
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)
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 Maybe BufSpan
_) strictlyContains :: SrcSpan -> SrcSpan -> Bool
`strictlyContains` (RealSrcSpan RealSrcSpan
s2 Maybe BufSpan
_)
= 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
findName :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> ModInfo
-> String
-> ExceptT SDoc m Name
findName :: forall (m :: Type -> Type).
GhcMonad m =>
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 a. a -> ExceptT SDoc m a
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)
resolveNameFromModule :: GhcMonad m
=> Map ModuleName ModInfo
-> Name
-> ExceptT SDoc m Name
resolveNameFromModule :: forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo -> Name -> ExceptT SDoc m Name
resolveNameFromModule Map ModuleName ModInfo
infos Name
name = do
GenModule Unit
modL <- ExceptT SDoc m (GenModule Unit)
-> (GenModule Unit -> ExceptT SDoc m (GenModule Unit))
-> Maybe (GenModule Unit)
-> ExceptT SDoc m (GenModule Unit)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDoc -> ExceptT SDoc m (GenModule Unit)
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (SDoc -> ExceptT SDoc m (GenModule Unit))
-> SDoc -> ExceptT SDoc m (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ SDoc
"No module for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) GenModule Unit -> ExceptT SDoc m (GenModule Unit)
forall a. a -> ExceptT SDoc m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (GenModule Unit) -> ExceptT SDoc m (GenModule Unit))
-> Maybe (GenModule Unit) -> ExceptT SDoc m (GenModule Unit)
forall a b. (a -> b) -> a -> b
$
Name -> Maybe (GenModule Unit)
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 (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
modL) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
":" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenModule Unit
modL)) ModInfo -> ExceptT SDoc m ModInfo
forall a. a -> ExceptT SDoc m a
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 (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
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 a. a -> ExceptT SDoc m a
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)
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
findType :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo, Type)
findType :: forall (m :: Type -> Type).
GhcMonad m =>
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 a. a -> m a
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 (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
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 a. a -> ExceptT SDoc m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModInfo
info, Type
ty)
where
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
guessModule :: GhcMonad m
=> Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule :: forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule Map ModuleName ModInfo
infos FilePath
fp = do
Target
target <- m Target -> MaybeT m Target
forall (m :: Type -> Type) a. Monad m => m a -> MaybeT m a
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 UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget FilePath
fp Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing
case Target -> TargetId
targetId Target
target of
TargetModule ModuleName
mn -> ModuleName -> MaybeT m ModuleName
forall a. a -> MaybeT m a
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' :: forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> MaybeT m ModuleName
guessModule' FilePath
fp' = case FilePath -> Maybe ModuleName
findModByFp FilePath
fp' of
Just ModuleName
mn -> ModuleName -> MaybeT m ModuleName
forall a. a -> MaybeT m a
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 a. IO a -> MaybeT m a
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 (m :: Type -> Type) a. Monad m => m a -> MaybeT m a
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 UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget FilePath
fp'' Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing
case Target -> TargetId
targetId Target
target' of
TargetModule ModuleName
mn -> ModuleName -> MaybeT m ModuleName
forall a. a -> MaybeT m a
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 a. a -> m a
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
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
-> m (Map ModuleName ModInfo)
collectInfo :: forall (m :: Type -> Type).
GhcMonad m =>
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
UnitState
unit_state <- (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState) -> m HscEnv -> m UnitState
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
IO [ModuleName] -> m [ModuleName]
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> Map ModuleName ModInfo -> m (Map ModuleName ModInfo)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map ModuleName ModInfo
ms
[ModuleName]
invalidated -> do
IO () -> m ()
forall a. IO a -> m a
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 a. [a] -> 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
-> UnitState
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
forall {m :: Type -> Type}.
GhcMonad m =>
DynFlags
-> UnitState
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
go DynFlags
df UnitState
unit_state) Map ModuleName ModInfo
ms [ModuleName]
invalidated
where
go :: DynFlags
-> UnitState
-> Map ModuleName ModInfo
-> ModuleName
-> m (Map ModuleName ModInfo)
go DynFlags
df UnitState
unit_state 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 a. a -> m a
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 e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch`
(\(SomeException
e :: SomeException) -> do
IO () -> m ()
forall a. IO a -> m a
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 -> UnitState -> NamePprCtx -> SDoc -> FilePath
showSDocForUser DynFlags
df UnitState
unit_state NamePprCtx
alwaysQualify
(SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ SDoc
"Error while getting type info from" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
":" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
Map ModuleName ModInfo -> m (Map ModuleName ModInfo)
forall a. a -> m a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
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
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo :: forall (m :: Type -> Type). GhcMonad m => 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
let allTypes :: [SpanInfo]
allTypes = TypecheckedModule -> [SpanInfo]
processAllTypeCheckedModule TypecheckedModule
typechecked
let i :: ModuleInfo
i = TypecheckedModule -> ModuleInfo
tm_checked_module_info TypecheckedModule
typechecked
UTCTime
ts <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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 a. a -> m a
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)
processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]
processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]
processAllTypeCheckedModule TypecheckedModule
tcm
= ((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
bts :: [Maybe (Maybe Id, SrcSpan, Type)]
bts = (LocatedA (HsBindLR GhcTc GhcTc)
-> Maybe (Maybe Id, SrcSpan, Type))
-> [LocatedA (HsBindLR GhcTc GhcTc)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> [a] -> [b]
map LHsBind GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
LocatedA (HsBindLR GhcTc GhcTc) -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLHsBind ([LocatedA (HsBindLR GhcTc GhcTc)]
-> [Maybe (Maybe Id, SrcSpan, Type)])
-> [LocatedA (HsBindLR GhcTc GhcTc)]
-> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [LocatedA (HsBindLR GhcTc GhcTc)]
forall a. Typeable a => TypecheckedSource -> [LocatedA a]
listifyAllSpans TypecheckedSource
Bag (LocatedA (HsBindLR GhcTc GhcTc))
tcs
ets :: [Maybe (Maybe Id, SrcSpan, Type)]
ets = (LocatedA (HsExpr GhcTc) -> Maybe (Maybe Id, SrcSpan, Type))
-> [LocatedA (HsExpr GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> [a] -> [b]
map LHsExpr GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
LocatedA (HsExpr GhcTc) -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLHsExpr ([LocatedA (HsExpr GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)])
-> [LocatedA (HsExpr GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [LocatedA (HsExpr GhcTc)]
forall a. Typeable a => TypecheckedSource -> [LocatedA a]
listifyAllSpans TypecheckedSource
Bag (LocatedA (HsBindLR GhcTc GhcTc))
tcs
pts :: [Maybe (Maybe Id, SrcSpan, Type)]
pts = (LocatedA (Pat GhcTc) -> Maybe (Maybe Id, SrcSpan, Type))
-> [LocatedA (Pat GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
LocatedA (Pat GhcTc) -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLPat ([LocatedA (Pat GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)])
-> [LocatedA (Pat GhcTc)] -> [Maybe (Maybe Id, SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ TypecheckedSource -> [LocatedA (Pat GhcTc)]
forall a. Typeable a => TypecheckedSource -> [LocatedA a]
listifyAllSpans TypecheckedSource
Bag (LocatedA (HsBindLR GhcTc GhcTc))
tcs
tcs :: TypecheckedSource
tcs = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
tcm
getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLHsBind (L SrcSpanAnnA
_spn FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcTc
pid,fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MG XMG GhcTc (LHsExpr GhcTc)
_ XRec GhcTc [LMatch GhcTc (LHsExpr GhcTc)]
_})
= (Maybe Id, SrcSpan, Type) -> Maybe (Maybe Id, SrcSpan, Type)
forall a. a -> Maybe a
Just (Id -> Maybe Id
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
pid), GenLocated SrcSpanAnnN Id -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP GhcTc
GenLocated SrcSpanAnnN Id
pid,Id -> Type
varType (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
pid))
getTypeLHsBind LHsBind GhcTc
_ = Maybe (Maybe Id, SrcSpan, Type)
forall a. Maybe a
Nothing
getTypeLHsExpr :: LHsExpr GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
getTypeLHsExpr :: LHsExpr GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLHsExpr LHsExpr GhcTc
e = (Maybe Id, SrcSpan, Type) -> Maybe (Maybe Id, SrcSpan, Type)
forall a. a -> Maybe a
Just (Maybe Id
mid, LocatedA (HsExpr GhcTc) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
e, LHsExpr GhcTc -> Type
lhsExprType LHsExpr GhcTc
e)
where
mid :: Maybe Id
mid :: Maybe Id
mid | HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
i) <- HsExpr GhcTc -> HsExpr GhcTc
unwrapVar (LocatedA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
e) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
i
| Bool
otherwise = Maybe Id
forall a. Maybe a
Nothing
unwrapVar :: HsExpr GhcTc -> HsExpr GhcTc
unwrapVar (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
var))) = HsExpr GhcTc
var
unwrapVar HsExpr GhcTc
e' = HsExpr GhcTc
e'
getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id, SrcSpan, Type)
getTypeLPat (L SrcSpanAnnA
spn Pat GhcTc
pat) = (Maybe Id, SrcSpan, Type) -> Maybe (Maybe Id, SrcSpan, Type)
forall a. a -> Maybe a
Just (Pat GhcTc -> Maybe Id
getMaybeId Pat GhcTc
pat,SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
spn,Pat GhcTc -> Type
hsPatType Pat GhcTc
pat)
where
getMaybeId :: Pat GhcTc -> Maybe Id
getMaybeId :: Pat GhcTc -> Maybe Id
getMaybeId (VarPat XVarPat GhcTc
_ (L SrcSpanAnnN
_ Id
vid)) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
vid
getMaybeId Pat GhcTc
_ = Maybe Id
forall a. Maybe a
Nothing
listifyAllSpans :: Typeable a => TypecheckedSource -> [LocatedA a]
listifyAllSpans :: forall a. Typeable a => TypecheckedSource -> [LocatedA a]
listifyAllSpans = ([LocatedA a] -> [LocatedA a] -> [LocatedA a])
-> [LocatedA a] -> GenericQ [LocatedA a] -> GenericQ [LocatedA a]
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans [LocatedA a] -> [LocatedA a] -> [LocatedA a]
forall a. [a] -> [a] -> [a]
(++) [] ([] [LocatedA a] -> (LocatedA a -> [LocatedA a]) -> a -> [LocatedA a]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\LocatedA a
x -> [LocatedA a
x | LocatedA a -> Bool
forall {a} {e}. GenLocated (SrcSpanAnn' a) e -> Bool
p LocatedA a
x]))
where
p :: GenLocated (SrcSpanAnn' a) e -> Bool
p (L SrcSpanAnn' a
spn e
_) = SrcSpan -> Bool
isGoodSrcSpan (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
spn)
everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans :: forall r. (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 b a. (b -> a -> b) -> b -> [a] -> b
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]
forall u. (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 a -> r
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
toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
toSpanInfo :: (Maybe Id, SrcSpan, Type) -> Maybe SpanInfo
toSpanInfo (Maybe Id
n,RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_,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
type GenericQ r = forall a. Data a => a -> r
mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
(r
r mkQ :: forall a b r. (Typeable a, Typeable b) => 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)