Show definitions of top-level vars on hover

src/lib/Core.hs

@@ -357,7 +357,7 @@ lookupSourceMap :: EnvReader m => SourceName -> m n (Maybe (UVar n))
 lookupSourceMap sourceName = do
   sm <- withEnv $ envSourceMap . moduleEnv
   case lookupSourceMapPure sm sourceName of
-    LocalVar x:_  -> return $ Just x
+    LocalVar _ x:_  -> return $ Just x
     [ModuleVar _ (Just x)] -> return $ Just x
     _   -> return Nothing
 

src/lib/Err.hs

@@ -574,5 +574,9 @@ instance Pretty Err where
   pretty e = pretty $ printErr e
 
 instance ToJSON SrcId
-instance Hashable InfVarDesc
+
 instance Store InfVarDesc
+instance Store SrcId
+
+instance Hashable InfVarDesc
+instance Hashable SrcId

src/lib/Name.hs

@@ -1292,6 +1292,10 @@ instance Monad m => ScopeExtender (ScopeReaderT m) where
          let env' = extendOutMap scope $ toScopeFrag b
          runReaderT (runScopeReaderT' $ cont b e) (Distinct, env')
 
+instance MonadTrans1 ScopeReaderT where
+  lift1 m = ScopeReaderT $ lift m
+  {-# INLINE lift1 #-}
+
 -- === OutReader monad: reads data in the output name space ===
 
 class OutReader (e::E) (m::MonadKind1) | m -> e where

src/lib/RenderHtml.hs

@@ -154,7 +154,16 @@ renderFocus srcId node = case gtnChildren node of
   _ -> []  -- not a lexeme
 
 renderNamingInfo :: NamingInfo -> RenderedOutputs
-renderNamingInfo _ = mempty
+renderNamingInfo (NamingInfo m) = [RenderedTreeNodeUpdate treeNodeUpdate]
+  where
+    treeNodeUpdate = M.toList m <&> \(sid, node) ->
+      (sid, Update $ renderNameInfo node)
+
+renderNameInfo :: NameInfo -> TreeNodeUpdate
+renderNameInfo = \case
+  LocalOcc _ -> TreeNodeUpdate mempty mempty
+  LocalBinder _ -> TreeNodeUpdate mempty mempty
+  TopOcc s -> TreeNodeUpdate NoChange (OverwriteWith s)
 
 renderTypeInfo :: TypeInfo -> RenderedOutputs
 renderTypeInfo _ = mempty

src/lib/SourceRename.hs

@@ -11,13 +11,16 @@ module SourceRename ( renameSourceNamesTopUDecl, uDeclErrSourceMap
 
 import Prelude hiding (id, (.))
 import Control.Category
-import Control.Monad.Except hiding (Except)
+import Control.Monad.Reader
+import Control.Monad.State.Strict
 import qualified Data.Set        as S
 import qualified Data.Map.Strict as M
 
 import Err
 import Name
 import Core (EnvReader (..), withEnv, lookupSourceMapPure)
+import MonadUtil
+import MTL1
 import PPrint
 import IRVariants
 import Types.Source
@@ -26,18 +29,18 @@ import Types.Top (Env (..), ModuleEnv (..))
 
 renameSourceNamesTopUDecl
   :: (Fallible1 m, EnvReader m, TopLogger1 m)
-  => ModuleSourceName -> UTopDecl VoidS VoidS -> m n (Abs UTopDecl SourceMap n)
-renameSourceNamesTopUDecl mname decl = do
+  => TopNameDescription -> UTopDecl VoidS VoidS -> m n (Abs UTopDecl SourceMap n)
+renameSourceNamesTopUDecl desc decl = do
   Distinct <- getDistinct
   Abs renamedDecl sourceMapLocalNames <- liftRenamer $ sourceRenameTopUDecl decl
-  let sourceMap = SourceMap $ fmap (fmap (\(LocalVar v) -> ModuleVar mname (Just v))) $
+  let sourceMap = SourceMap $ fmap (fmap (\(LocalVar _ v) -> ModuleVar desc (Just v))) $
                     fromSourceMap sourceMapLocalNames
   return $ Abs renamedDecl sourceMap
 {-# SCC renameSourceNamesTopUDecl #-}
 
-uDeclErrSourceMap:: ModuleSourceName -> UTopDecl VoidS VoidS -> SourceMap n
-uDeclErrSourceMap mname decl =
-  SourceMap $ M.fromSet (const [ModuleVar mname Nothing]) (sourceNames decl)
+uDeclErrSourceMap:: TopNameDescription -> UTopDecl VoidS VoidS -> SourceMap n
+uDeclErrSourceMap desc decl =
+  SourceMap $ M.fromSet (const [ModuleVar desc Nothing]) (sourceNames decl)
 {-# SCC uDeclErrSourceMap #-}
 
 renameSourceNamesUExpr :: (Fallible1 m, EnvReader m, TopLogger1 m) => UExpr VoidS -> m n (UExpr n)
@@ -59,34 +62,41 @@ data RenamerSubst n = RenamerSubst { renamerSourceMap :: SourceMap n
                                    , renamerMayShadow :: Bool }
 
 newtype RenamerM (n::S) (a:: *) =
-  RenamerM { runRenamerM :: OutReaderT RenamerSubst (ScopeReaderT Except) n a }
+  RenamerM { runRenamerM :: ReaderT1 RenamerSubst (ScopeReaderT (ExceptT (State NamingInfo))) n a }
   deriving ( Functor, Applicative, Monad, MonadFail, Fallible
            , ScopeReader, ScopeExtender)
 
-liftRenamer :: (EnvReader m, Fallible1 m, SinkableE e) => RenamerM n (e n) -> m n (e n)
+liftRenamer :: (EnvReader m, Fallible1 m, SinkableE e, TopLogger1 m) => RenamerM n (e n) -> m n (e n)
 liftRenamer cont = do
   sm <- withEnv $ envSourceMap . moduleEnv
   Distinct <- getDistinct
-  (liftExcept =<<) $ liftScopeReaderT $
-    runOutReaderT (RenamerSubst sm False) $ runRenamerM $ cont
+  m <- liftScopeReaderT $ runReaderT1 (RenamerSubst sm False) $ runRenamerM $ cont
+  let (ans, namingInfo) = runState (runExceptT m) mempty
+  emitLog $ Outputs [SourceInfo $ SINamingInfo namingInfo]
+  liftExcept ans
 
 class ( Monad1 m, ScopeReader m
       , ScopeExtender m, Fallible1 m) => Renamer m where
   askMayShadow :: m n Bool
   setMayShadow :: Bool -> m n a -> m n a
   askSourceMap    :: m n (SourceMap n)
-  extendSourceMap :: SourceName -> UVar n -> m n a -> m n a
+  extendSourceMap :: SrcId -> SourceName -> UVar n -> m n a -> m n a
+  emitNameInfo :: SrcId -> NameInfo -> m n ()
 
 instance Renamer RenamerM where
-  askMayShadow = RenamerM $ renamerMayShadow <$> askOutReader
-  askSourceMap = RenamerM $ renamerSourceMap <$> askOutReader
+  askMayShadow = RenamerM $ renamerMayShadow <$> ask
+  askSourceMap = RenamerM $ renamerSourceMap <$> ask
   setMayShadow mayShadow (RenamerM cont) = RenamerM do
-    RenamerSubst sm _ <- askOutReader
-    localOutReader (RenamerSubst sm mayShadow) cont
-  extendSourceMap name var (RenamerM cont) = RenamerM do
-    RenamerSubst sm mayShadow <- askOutReader
-    let ext = SourceMap $ M.singleton name [LocalVar var]
-    localOutReader (RenamerSubst (sm <> ext) mayShadow) cont
+    RenamerSubst sm _ <- ask
+    local (const $ RenamerSubst sm mayShadow) cont
+  extendSourceMap sid name var (RenamerM cont) = RenamerM do
+    RenamerSubst sm mayShadow <- ask
+    let ext = SourceMap $ M.singleton name [LocalVar sid var]
+    local (const $ RenamerSubst (sm <> ext) mayShadow) cont
+  emitNameInfo sid info = do
+    NamingInfo curNameInfo <- RenamerM $ lift11 $ lift1 $ lift get
+    let newNameInfo = M.insert sid info curNameInfo
+    RenamerM $ lift11 $ lift1 $ lift $ put $ NamingInfo newNameInfo
 
 class SourceRenamableE e where
   sourceRenameE :: (Distinct o, Renamer m) => e i -> m o (e o)
@@ -107,20 +117,27 @@ lookupSourceName sid v = do
   sm <- askSourceMap
   case lookupSourceMapPure sm v of
     [] -> throw sid $ UnboundVarErr $ pprint v
-    LocalVar v' : _ -> return v'
-    [ModuleVar _ maybeV] -> case maybeV of
-      Just v' -> return v'
+    LocalVar binderSid v' : _ -> do
+      emitNameInfo sid $ LocalOcc binderSid
+      return v'
+    [ModuleVar desc maybeV] -> case maybeV of
+      Just v' -> do
+        emitNameInfo sid $ TopOcc (prettyNameDesc desc)
+        return v'
       Nothing -> throw sid $ VarDefErr $ pprint v
     vs -> throw sid $ AmbiguousVarErr (pprint v) (map wherePretty vs)
     where
       wherePretty :: SourceNameDef n -> String
-      wherePretty (ModuleVar mname _) = case mname of
+      wherePretty (ModuleVar desc _) = case tndModuleName desc of
         Main -> "in this file"
         Prelude -> "in the prelude"
         OrdinaryModule mname' -> "in " ++ pprint mname'
-      wherePretty (LocalVar _) =
+      wherePretty (LocalVar _ _) =
         error "shouldn't be possible because module vars can't shadow local ones"
 
+      prettyNameDesc :: TopNameDescription -> String
+      prettyNameDesc s = tndTextSummary s -- TODO: also mention the module where it comes from
+
 instance SourceRenamableE (SourceNameOr (Name (AtomNameC CoreIR))) where
   sourceRenameE (SourceName sid sourceName) = do
     lookupSourceName sid sourceName >>= \case
@@ -302,10 +319,10 @@ sourceRenameUBinder asUVar (WithSrcB sid ubinder) cont = case ubinder of
     mayShadow <- askMayShadow
     let shadows = M.member b sm
     when (not mayShadow && shadows) $ throw sid $ RepeatedVarErr $ pprint b
-    withFreshM (getNameHint b) \freshName -> do
+    withFreshM (getNameHint b) \name -> do
       Distinct <- getDistinct
-      extendSourceMap b (asUVar $ binderName freshName) $
-        cont $ WithSrcB sid $ UBind b freshName
+      extendSourceMap sid b (asUVar $ binderName name) $
+        cont $ WithSrcB sid $ UBind b name
   UBind _ _ -> error "Shouldn't be source-renaming internal names"
   UIgnore -> cont $ WithSrcB sid $ UIgnore
 

src/lib/TopLevel.hs

@@ -223,15 +223,15 @@ evalSourceBlock mname block = do
   case (maybeErr, sbContents block) of
     (Failure _, TopDecl decl) -> do
       case parseDecl decl of
-        Success decl' -> emitSourceMap $ uDeclErrSourceMap mname decl'
+        Success decl' -> emitSourceMap $ uDeclErrSourceMap (makeTopNameDescription mname block) decl'
         Failure _ -> return ()
     _ -> return ()
   return maybeErr
 
 evalSourceBlock'
   :: (Topper m, Mut n) => ModuleSourceName -> SourceBlock -> m n ()
 evalSourceBlock' mname block = case sbContents block of
-  TopDecl decl -> parseDecl decl >>= execUDecl mname
+  TopDecl decl -> parseDecl decl >>= execUDecl (makeTopNameDescription mname block)
   Command cmd expr' -> do
    expr <- parseExpr expr'
    case cmd of
@@ -274,8 +274,9 @@ evalSourceBlock' mname block = case sbContents block of
         let hint = fromString $ pprint dexName
         fTop  <- emitBinding hint $ TopFunBinding $ FFITopFun (pprint $ withoutSrc fname) impFunTy
         vCore <- emitBinding hint $ AtomNameBinding $ FFIFunBound naryPiTy fTop
+        let desc = makeTopNameDescription mname block
         emitSourceMap $ SourceMap $
-          M.singleton dexName [ModuleVar mname (Just $ UAtomVar vCore)]
+          M.singleton dexName [ModuleVar desc (Just $ UAtomVar vCore)]
   DeclareCustomLinearization fname zeros g -> do
     expr <- parseExpr g
     lookupSourceMap (withoutSrc fname) >>= \case
@@ -542,10 +543,10 @@ evalDictSpecializations ds = do
   return ()
 
 execUDecl
-  :: (Topper m, Mut n) => ModuleSourceName -> UTopDecl VoidS VoidS -> m n ()
-execUDecl mname decl = do
+  :: (Topper m, Mut n) => TopNameDescription -> UTopDecl VoidS VoidS -> m n ()
+execUDecl desc decl = do
   logPass Parse decl
-  renamed@(Abs renamedDecl sourceMap) <- renameSourceNamesTopUDecl mname decl
+  renamed@(Abs renamedDecl sourceMap) <- renameSourceNamesTopUDecl desc decl
   logPass RenamePass renamed
   inferenceResult <- checkPass TypePass $ inferTopUDecl renamedDecl sourceMap
   case inferenceResult of

src/lib/Types/Source.hs

@@ -25,6 +25,7 @@ import Data.Hashable
 import Data.Foldable
 import qualified Data.Map.Strict       as M
 import qualified Data.Set              as S
+import qualified Data.Text             as T
 import Data.Text (Text)
 import Data.Word
 import Data.Text.Prettyprint.Doc (line, group, parens, nest, align, punctuate, hsep)
@@ -111,8 +112,8 @@ data GroupTreeNode = GroupTreeNode
   , gtnIsAtomicLexeme :: Bool }
     deriving (Show, Eq, Generic)
 
-data NamingInfo = NamingInfo (M.Map SrcId NameInfo)
-  deriving (Show, Eq, Generic)
+newtype NamingInfo = NamingInfo (M.Map SrcId NameInfo)
+  deriving (Show, Eq, Generic, Semigroup, Monoid)
 data NameInfo =
    LocalBinder [SrcId] -- src ids of groups for which this binder is in scope
  | LocalOcc SrcId      -- src id of this occ's binder
@@ -549,16 +550,25 @@ instance FromSourceNameW (b n l) => FromSourceNameW (WithSrcB b n l) where
 
 -- === SourceMap ===
 
+-- TODO: line in module where it's defined
+data TopNameDescription = TopNameDescription
+  { tndModuleName  :: ModuleSourceName
+  , tndTextSummary :: String }
+    deriving (Show, Eq, Ord, Generic)
+
 data SourceNameDef n =
-    LocalVar  (UVar n)                          -- bound within a decl or expression
+    LocalVar  SrcId (UVar n)                      -- bound within a decl or expression
     -- the Nothing case is for vars whose definitions have errors
-  | ModuleVar ModuleSourceName (Maybe (UVar n)) -- bound at the module level
+  | ModuleVar TopNameDescription (Maybe (UVar n)) -- bound at the module level
     deriving (Show, Generic)
 
 data SourceMap (n::S) = SourceMap
   {fromSourceMap :: M.Map SourceName [SourceNameDef n]}
   deriving Show
 
+makeTopNameDescription :: ModuleSourceName -> SourceBlock -> TopNameDescription
+makeTopNameDescription mname sb = TopNameDescription mname (T.unpack $ sbText sb)
+
 -- === Source modules ===
 
 data ModuleSourceName = Prelude | Main | OrdinaryModule SourceName
@@ -772,11 +782,11 @@ instance Monoid (SourceMap n) where
   mempty = SourceMap mempty
 
 instance GenericE SourceNameDef where
-  type RepE SourceNameDef = EitherE UVar (LiftE ModuleSourceName `PairE` MaybeE UVar)
-  fromE (LocalVar v) = LeftE v
+  type RepE SourceNameDef = EitherE (LiftE SrcId `PairE` UVar) (LiftE TopNameDescription `PairE` MaybeE UVar)
+  fromE (LocalVar sid v) = LeftE (PairE (LiftE sid) v)
   fromE (ModuleVar name maybeUVar) = RightE (PairE (LiftE name) (toMaybeE maybeUVar))
   {-# INLINE fromE #-}
-  toE (LeftE v) = LocalVar v
+  toE (LeftE (PairE (LiftE sid) v)) = LocalVar sid v
   toE (RightE (PairE (LiftE name) maybeUVar)) = ModuleVar name (fromMaybeE maybeUVar)
   {-# INLINE toE #-}
 
@@ -803,9 +813,9 @@ instance RenameE        SourceMap
 
 instance Pretty (SourceNameDef n) where
   pretty def = case def of
-    LocalVar v -> pretty v
+    LocalVar _ v -> pretty v
     ModuleVar _ Nothing -> "<error in definition>"
-    ModuleVar mname (Just v) -> pretty v <> " defined in " <> pretty mname
+    ModuleVar desc (Just v) -> pretty v <> " defined in " <> pretty (tndModuleName desc)
 
 instance Pretty ModuleSourceName where
   pretty Main = "main"
@@ -948,8 +958,10 @@ instance Store ModuleSourceName
 instance Store (UVar n)
 instance Store (SourceNameDef n)
 instance Store (SourceMap n)
+instance Store TopNameDescription
 
 instance Hashable ModuleSourceName
+instance Hashable TopNameDescription
 
 deriving instance Show (UBinder' s n l)
 deriving instance Show (UDataDefTrail n)