never executed always true always false
    1 {-# LANGUAGE LambdaCase          #-}
    2 {-# LANGUAGE RankNTypes          #-}
    3 {-# LANGUAGE OverloadedStrings   #-}
    4 {-# LANGUAGE ScopedTypeVariables #-}
    5 {-# LANGUAGE ViewPatterns        #-}
    6 
    7 {-# OPTIONS -fno-warn-name-shadowing #-}
    8 
    9 -- | Get information on modules, expressions, and identifiers
   10 module GHCi.UI.Info
   11     ( ModInfo(..)
   12     , SpanInfo(..)
   13     , spanInfoFromRealSrcSpan
   14     , collectInfo
   15     , findLoc
   16     , findNameUses
   17     , findType
   18     , getModInfo
   19     ) where
   20 
   21 import           Control.Exception
   22 import           Control.Monad
   23 import           Control.Monad.Catch as MC
   24 import           Control.Monad.Trans.Class
   25 import           Control.Monad.Trans.Except
   26 import           Control.Monad.Trans.Maybe
   27 import           Data.Data
   28 import           Data.Function
   29 import           Data.List (find, sortBy)
   30 import           Data.Map.Strict   (Map)
   31 import qualified Data.Map.Strict   as M
   32 import           Data.Maybe
   33 import           Data.Time
   34 import           Prelude           hiding (mod,(<>))
   35 import           System.Directory
   36 
   37 import           GHC.Hs.Syn.Type
   38 import           GHC.Driver.Session (HasDynFlags(..))
   39 import           GHC.Data.FastString
   40 import           GHC
   41 import           GHC.Driver.Monad
   42 import           GHC.Driver.Env
   43 import           GHC.Driver.Ppr
   44 import           GHC.Types.Name
   45 import           GHC.Types.Name.Set
   46 import           GHC.Utils.Outputable
   47 import           GHC.Types.SrcLoc
   48 import           GHC.Types.Var
   49 import qualified GHC.Data.Strict as Strict
   50 
   51 -- | Info about a module. This information is generated every time a
   52 -- module is loaded.
   53 data ModInfo = ModInfo
   54     { modinfoSummary    :: !ModSummary
   55       -- ^ Summary generated by GHC. Can be used to access more
   56       -- information about the module.
   57     , modinfoSpans      :: [SpanInfo]
   58       -- ^ Generated set of information about all spans in the
   59       -- module that correspond to some kind of identifier for
   60       -- which there will be type info and/or location info.
   61     , modinfoInfo       :: !ModuleInfo
   62       -- ^ Again, useful from GHC for accessing information
   63       -- (exports, instances, scope) from a module.
   64     , modinfoLastUpdate :: !UTCTime
   65       -- ^ The timestamp of the file used to generate this record.
   66     }
   67 
   68 -- | Type of some span of source code. Most of these fields are
   69 -- unboxed but Haddock doesn't show that.
   70 data SpanInfo = SpanInfo
   71     { spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan
   72       -- ^ The span we associate information with
   73     , spaninfoType      :: !(Maybe Type)
   74       -- ^ The 'Type' associated with the span
   75     , spaninfoVar       :: !(Maybe Id)
   76       -- ^ The actual 'Var' associated with the span, if
   77       -- any. This can be useful for accessing a variety of
   78       -- information about the identifier such as module,
   79       -- locality, definition location, etc.
   80     }
   81 
   82 instance Outputable SpanInfo where
   83   ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i
   84 
   85 -- | Test whether second span is contained in (or equal to) first span.
   86 -- This is basically 'containsSpan' for 'SpanInfo'
   87 containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
   88 containsSpanInfo = containsSpan `on` spaninfoSrcSpan
   89 
   90 -- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
   91 spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
   92 spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
   93 
   94 -- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
   95 -- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
   96 -- respectively)
   97 spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
   98 spanInfoFromRealSrcSpan spn mty mvar =
   99     SpanInfo spn mty mvar
  100 
  101 -- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
  102 -- only a 'RealSrcSpan'
  103 spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
  104 spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
  105 
  106 -- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
  107 srcSpanFilePath :: RealSrcSpan -> FilePath
  108 srcSpanFilePath = unpackFS . srcSpanFile
  109 
  110 -- | Try to find the location of the given identifier at the given
  111 -- position in the module.
  112 findLoc :: GhcMonad m
  113         => Map ModuleName ModInfo
  114         -> RealSrcSpan
  115         -> String
  116         -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
  117 findLoc infos span0 string = do
  118     name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
  119              guessModule infos (srcSpanFilePath span0)
  120 
  121     info  <- maybeToExceptT "No module info for current file! Try loading it?" $
  122              MaybeT $ pure $ M.lookup name infos
  123 
  124     name' <- findName infos span0 info string
  125 
  126     case getSrcSpan name' of
  127         UnhelpfulSpan{} -> do
  128             throwE ("Found a name, but no location information." <+>
  129                     "The module is:" <+>
  130                     maybe "<unknown>" (ppr . moduleName)
  131                           (nameModule_maybe name'))
  132 
  133         span' -> return (info,name',span')
  134 
  135 -- | Find any uses of the given identifier in the codebase.
  136 findNameUses :: (GhcMonad m)
  137              => Map ModuleName ModInfo
  138              -> RealSrcSpan
  139              -> String
  140              -> ExceptT SDoc m [SrcSpan]
  141 findNameUses infos span0 string =
  142     locToSpans <$> findLoc infos span0 string
  143   where
  144     locToSpans (modinfo,name',span') =
  145         stripSurrounding (span' : map toSrcSpan spans)
  146       where
  147         toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Strict.Nothing
  148         spans = filter ((== Just name') . fmap getName . spaninfoVar)
  149                        (modinfoSpans modinfo)
  150 
  151 -- | Filter out redundant spans which surround/contain other spans.
  152 stripSurrounding :: [SrcSpan] -> [SrcSpan]
  153 stripSurrounding xs = filter (not . isRedundant) xs
  154   where
  155     isRedundant x = any (x `strictlyContains`) xs
  156 
  157     (RealSrcSpan s1 _) `strictlyContains` (RealSrcSpan s2 _)
  158          = s1 /= s2 && s1 `containsSpan` s2
  159     _                `strictlyContains` _ = False
  160 
  161 -- | Try to resolve the name located at the given position, or
  162 -- otherwise resolve based on the current module's scope.
  163 findName :: GhcMonad m
  164          => Map ModuleName ModInfo
  165          -> RealSrcSpan
  166          -> ModInfo
  167          -> String
  168          -> ExceptT SDoc m Name
  169 findName infos span0 mi string =
  170     case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
  171       Nothing -> tryExternalModuleResolution
  172       Just name ->
  173         case getSrcSpan name of
  174           UnhelpfulSpan {} -> tryExternalModuleResolution
  175           RealSrcSpan   {} -> return (getName name)
  176   where
  177     tryExternalModuleResolution =
  178       case find (matchName $ mkFastString string)
  179                 (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
  180         Nothing -> throwE "Couldn't resolve to any modules."
  181         Just imported -> resolveNameFromModule infos imported
  182 
  183     matchName :: FastString -> Name -> Bool
  184     matchName str name =
  185       str ==
  186       occNameFS (getOccName name)
  187 
  188 -- | Try to resolve the name from another (loaded) module's exports.
  189 resolveNameFromModule :: GhcMonad m
  190                       => Map ModuleName ModInfo
  191                       -> Name
  192                       -> ExceptT SDoc m Name
  193 resolveNameFromModule infos name = do
  194      modL <- maybe (throwE $ "No module for" <+> ppr name) return $
  195              nameModule_maybe name
  196 
  197      info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>
  198                             ppr modL)) return $
  199              M.lookup (moduleName modL) infos
  200 
  201      maybe (throwE "No matching export in any local modules.") return $
  202          find (matchName name) (modInfoExports (modinfoInfo info))
  203   where
  204     matchName :: Name -> Name -> Bool
  205     matchName x y = occNameFS (getOccName x) ==
  206                     occNameFS (getOccName y)
  207 
  208 -- | Try to resolve the type display from the given span.
  209 resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
  210 resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
  211                         reverse spans' `spaninfosWithin` si
  212 
  213 -- | Try to find the type of the given span.
  214 findType :: GhcMonad m
  215          => Map ModuleName ModInfo
  216          -> RealSrcSpan
  217          -> String
  218          -> ExceptT SDoc m (ModInfo, Type)
  219 findType infos span0 string = do
  220     name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
  221              guessModule infos (srcSpanFilePath span0)
  222 
  223     info  <- maybeToExceptT "No module info for current file! Try loading it?" $
  224              MaybeT $ pure $ M.lookup name infos
  225 
  226     case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
  227         Nothing -> (,) info <$> lift (exprType TM_Inst string)
  228         Just ty -> return (info, ty)
  229   where
  230     -- | Try to resolve the type display from the given span.
  231     resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
  232     resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
  233                             reverse spans' `spaninfosWithin` si
  234 
  235 -- | Guess a module name from a file path.
  236 guessModule :: GhcMonad m
  237             => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
  238 guessModule infos fp = do
  239     target <- lift $ guessTarget fp Nothing Nothing
  240     case targetId target of
  241         TargetModule mn  -> return mn
  242         TargetFile fp' _ -> guessModule' fp'
  243   where
  244     guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
  245     guessModule' fp' = case findModByFp fp' of
  246         Just mn -> return mn
  247         Nothing -> do
  248             fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
  249 
  250             target' <- lift $ guessTarget fp'' Nothing Nothing
  251             case targetId target' of
  252                 TargetModule mn -> return mn
  253                 _               -> MaybeT . pure $ findModByFp fp''
  254 
  255     findModByFp :: FilePath -> Maybe ModuleName
  256     findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
  257       where
  258         mifp :: (ModuleName, ModInfo) -> Maybe FilePath
  259         mifp = ml_hs_file . ms_location . modinfoSummary . snd
  260 
  261 
  262 -- | Collect type info data for the loaded modules.
  263 collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
  264                -> m (Map ModuleName ModInfo)
  265 collectInfo ms loaded = do
  266     df <- getDynFlags
  267     unit_state <- hsc_units <$> getSession
  268     liftIO (filterM cacheInvalid loaded) >>= \case
  269         [] -> return ms
  270         invalidated -> do
  271             liftIO (putStrLn ("Collecting type info for " ++
  272                               show (length invalidated) ++
  273                               " module(s) ... "))
  274 
  275             foldM (go df unit_state) ms invalidated
  276   where
  277     go df unit_state m name = do { info <- getModInfo name; return (M.insert name info m) }
  278                    `MC.catch`
  279                    (\(e :: SomeException) -> do
  280                          liftIO $ putStrLn
  281                                 $ showSDocForUser df unit_state alwaysQualify
  282                                 $ "Error while getting type info from" <+>
  283                                   ppr name <> ":" <+> text (show e)
  284                          return m)
  285 
  286     cacheInvalid name = case M.lookup name ms of
  287         Nothing -> return True
  288         Just mi -> do
  289             let fp = srcFilePath (modinfoSummary mi)
  290                 last' = modinfoLastUpdate mi
  291             current <- getModificationTime fp
  292             exists <- doesFileExist fp
  293             if exists
  294                 then return $ current /= last'
  295                 else return True
  296 
  297 -- | Get the source file path from a ModSummary.
  298 -- If the .hs file is missing, and the .o file exists,
  299 -- we return the .o file path.
  300 srcFilePath :: ModSummary -> FilePath
  301 srcFilePath modSum = fromMaybe obj_fp src_fp
  302     where
  303         src_fp = ml_hs_file ms_loc
  304         obj_fp = ml_obj_file ms_loc
  305         ms_loc = ms_location modSum
  306 
  307 -- | Get info about the module: summary, types, etc.
  308 getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
  309 getModInfo name = do
  310     m <- getModSummary name
  311     p <- parseModule m
  312     typechecked <- typecheckModule p
  313     let allTypes = processAllTypeCheckedModule typechecked
  314     let i = tm_checked_module_info typechecked
  315     ts <- liftIO $ getModificationTime $ srcFilePath m
  316     return (ModInfo m allTypes i ts)
  317 
  318 -- | Get ALL source spans in the module.
  319 processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]
  320 processAllTypeCheckedModule tcm
  321   = mapMaybe toSpanInfo
  322   $ sortBy cmpSpan
  323   $ catMaybes (bts ++ ets ++ pts)
  324   where
  325     bts = map getTypeLHsBind $ listifyAllSpans tcs
  326     ets = map getTypeLHsExpr $ listifyAllSpans tcs
  327     pts = map getTypeLPat    $ listifyAllSpans tcs
  328 
  329     tcs = tm_typechecked_source tcm
  330 
  331     -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
  332     getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
  333     getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
  334         = Just (Just (unLoc pid), getLocA pid,varType (unLoc pid))
  335     getTypeLHsBind _ = Nothing
  336 
  337     -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
  338     getTypeLHsExpr :: LHsExpr GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
  339     getTypeLHsExpr e = Just (mid, getLocA e, lhsExprType e)
  340       where
  341         mid :: Maybe Id
  342         mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i
  343             | otherwise                              = Nothing
  344 
  345         unwrapVar (XExpr (WrapExpr (HsWrap _ var))) = var
  346         unwrapVar e'                                = e'
  347 
  348     -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
  349     getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
  350     getTypeLPat (L spn pat) = Just (getMaybeId pat,locA spn,hsPatType pat)
  351       where
  352         getMaybeId :: Pat GhcTc -> Maybe Id
  353         getMaybeId (VarPat _ (L _ vid)) = Just vid
  354         getMaybeId _                        = Nothing
  355 
  356     -- | Get ALL source spans in the source.
  357     listifyAllSpans :: Typeable a => TypecheckedSource -> [LocatedA a]
  358     listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
  359       where
  360         p (L spn _) = isGoodSrcSpan (locA spn)
  361 
  362     -- | Variant of @syb@'s @everything@ (which summarises all nodes
  363     -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
  364     everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
  365     everythingAllSpans k z f x
  366       | (False `mkQ` (const True :: NameSet -> Bool)) x = z
  367       | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
  368 
  369     cmpSpan (_,a,_) (_,b,_)
  370       | a `isSubspanOf` b = LT
  371       | b `isSubspanOf` a = GT
  372       | otherwise         = EQ
  373 
  374     -- | Pretty print the types into a 'SpanInfo'.
  375     toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
  376     toSpanInfo (n,RealSrcSpan spn _,typ)
  377         = Just $ spanInfoFromRealSrcSpan spn (Just typ) n
  378     toSpanInfo _ = Nothing
  379 
  380 -- helper stolen from @syb@ package
  381 type GenericQ r = forall a. Data a => a -> r
  382 
  383 mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
  384 (r `mkQ` br) a = maybe r br (cast a)