Permalink
Browse files

Merge branch 'definition_sites'

Conflicts:

	src/Scion/Session.hs
  • Loading branch information...
2 parents 49a0702 + fd036d5 commit aa6877c93cbff4fbce1022200727c8b2294ce44e @nominolo nominolo committed Apr 19, 2009
Showing with 217 additions and 6 deletions.
  1. +29 −0 emacs/scion.el
  2. +1 −0 scion.cabal
  3. +95 −0 src/Scion/Inspect/DefinitionSite.hs
  4. +28 −1 src/Scion/Server/Commands.hs
  5. +11 −3 src/Scion/Session.hs
  6. +50 −2 src/Scion/Types.hs
  7. +3 −0 src/Scion/Types/Notes.hs
View
@@ -28,6 +28,7 @@
(require 'easy-mmode)
(defalias 'define-minor-mode 'easy-mmode-define-minor-mode)))
(require 'hideshow)
+(require 'thingatpt)
(eval-when (compile)
(require 'apropos)
(require 'outline)
@@ -2053,6 +2054,7 @@ installed packages (However, not of the current project.)"
(define-key scion-mode-map "\M-n" 'scion-next-note-in-buffer)
(define-key scion-mode-map "\M-p" 'scion-previous-note-in-buffer)
(define-key scion-mode-map "\C-c\C-n" 'scion-list-compiler-notes)
+(define-key scion-mode-map [(control ?c) (control ?\.)] 'scion-goto-definition)
(defun haskell-insert-module-header (module-name &optional
author
@@ -2237,6 +2239,10 @@ forces it to be off. NIL toggles the current state."
(interactive)
(scion-eval '(dump-sources)))
+(defun scion-dump-defined-names ()
+ (interactive)
+ (scion-eval '(dump-defined-names)))
+
(define-key scion-mode-map "\C-c\C-t" 'scion-thing-at-point)
(provide 'scion)
@@ -2349,6 +2355,29 @@ LIBRARY or (EXECUTABLE <name>)."
(interactive "nVerbosity[0-3]: ")
(scion-eval `(set-verbosity ,v)))
+(defun scion-defined-names ()
+ (scion-eval '(defined-names)))
+
+(defun scion-ident-at-point ()
+ ;; TODO: recognise proper haskell symbols
+ (let ((s (thing-at-point 'symbol)))
+ (if s
+ (substring-no-properties s)
+ nil)))
+
+(defun scion-goto-definition (name)
+ (interactive
+ (let ((names (scion-defined-names))
+ (dflt (scion-ident-at-point)))
+ (if (find dflt names :test #'string=)
+ (list dflt)
+ (list (ido-completing-read "Goto Definition: " names nil nil dflt)))))
+ (let ((sites (scion-eval `(name-definitions ,name))))
+ (if (not sites)
+ (message "No definition site known")
+ (let* ((loc (car sites)) ;; XXX: deal with multiple locations
+ (dummy-note (list :warning loc "definition" "")))
+ (scion-goto-source-location dummy-note)))))
;; Local Variables:
;; outline-regexp: ";;;;+"
View
@@ -47,6 +47,7 @@ library
Scion.Inspect,
Scion.Inspect.Find,
Scion.Inspect.TypeOf,
+ Scion.Inspect.DefinitionSite,
Scion.Utils,
Scion.Session,
Scion.Configure,
@@ -0,0 +1,95 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE CPP #-}
+-- |
+-- Module : Scion.Inspect.DefinitionSite
+-- Copyright : (c) Thomas Schilling 2009
+-- License : BSD-style
+--
+-- Maintainer : nominolo@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Collecting and finding the definition site of an identifier.
+--
+-- This module analyses Haskell code to find the definition sites of
+-- identifiers within.
+--
+module Scion.Inspect.DefinitionSite where
+
+import Scion.Types
+import Scion.Types.Notes
+
+import GHC
+import Name ( getOccString, getSrcSpan )
+import Outputable ( showSDoc, ppr, Outputable, (<+>) )
+import PprTyThing ( pprTyThingInContext )
+import TyCon ( isCoercionTyCon )
+import Var ( globalIdVarDetails )
+import HscTypes ( isBootSummary )
+
+import qualified Data.Map as M
+import Data.List ( foldl' )
+import Data.Monoid
+import Control.Monad ( foldM )
+
+------------------------------------------------------------------------
+-- * Intended Interface
+
+-- | Construct a 'DefSiteDB' for a complete module graph.
+--
+-- Note: All the modules mentioned in the module graph must have been
+-- loaded. This is done either by a successful call to 'GHC.load' or by a
+-- call to 'GHC.loadModule' for each module (in dependency order).
+moduleGraphDefSiteDB ::
+ FilePath -- ^ Base path (see 'ghcSpanToLocation')
+ -> ModuleGraph
+ -> ScionM DefSiteDB
+moduleGraphDefSiteDB base_dir mg = do
+ let mg' = filter (not . isBootSummary) mg
+ foldM go emptyDefSiteDB mg'
+ where
+ go db modsum = do
+ db1 <- moduleSiteDB (base_dir, ms_mod modsum)
+ return (db1 `mappend` db)
+
+-- | Construct a 'DefSiteDB' for a single module only.
+moduleSiteDB :: (FilePath, Module)
+ -- ^ Base path (see 'ghcSpanToLocation') and module.
+ -> ScionM DefSiteDB
+moduleSiteDB (base_dir, mdl) = do
+ mb_mod_info <- getModuleInfo mdl
+ case mb_mod_info of
+ Nothing -> return emptyDefSiteDB
+ Just mod_info -> do
+ return $ mkSiteDB base_dir (modInfoTyThings mod_info)
+
+-- ** Internal Stuff
+
+-- | Construct a 'SiteDB' from a base directory and a list of 'TyThing's.
+mkSiteDB :: FilePath -> [TyThing] -> DefSiteDB
+mkSiteDB base_dir ty_things = foldl' go emptyDefSiteDB ty_things
+ where
+ -- TODO: there's probably more stuff to ignore
+ go db (ATyCon tycon) | isCoercionTyCon tycon = db -- ignore
+ go db ty_thing =
+ addToDB (getOccString ty_thing)
+ (ghcSpanToLocation base_dir (getSrcSpan ty_thing))
+ ty_thing db
+
+addToDB :: String -> Location -> TyThing -> DefSiteDB -> DefSiteDB
+addToDB nm loc ty_thing (DefSiteDB m) =
+ DefSiteDB (M.insertWith (++) nm [(loc,ty_thing)] m)
+
+
+-- | Dump a definition site DB to stdout. (For debugging purposes.)
+dumpDefSiteDB :: DefSiteDB -> String
+dumpDefSiteDB (DefSiteDB m) = unlines (map pp (M.assocs m))
+ where
+ pp (s, l_ty_things) = show s ++ ":\n" ++ unlines
+ [ " " ++ show (viewLoc l) ++ ", " ++ pp_ty_thing t
+ | (l, t) <- l_ty_things ]
+
+ pp_ty_thing tt@(AnId ident) =
+ showSDoc (pprTyThingInContext False tt <+> ppr (globalIdVarDetails ident))
+
+ pp_ty_thing tt = showSDoc (pprTyThingInContext False tt)
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, CPP #-}
+{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : Scion.Server.Commands
@@ -19,6 +19,7 @@ import Scion.Utils
import Scion.Session
import Scion.Server.Protocol
import Scion.Inspect
+import Scion.Inspect.DefinitionSite
import Scion.Configure
import FastString
@@ -80,6 +81,9 @@ allCommands =
, cmdLoad
, cmdSetVerbosity
, cmdGetVerbosity
+ , cmdDumpDefinedNames
+ , cmdDefinedNames
+ , cmdNameDefinitions
]
------------------------------------------------------------------------------
@@ -358,3 +362,26 @@ cmdCurrentCabalFile =
case r of
Right f -> return (Just f)
Left (_::SomeScionException) -> return Nothing)
+
+cmdDumpDefinedNames :: Command
+cmdDumpDefinedNames =
+ Command $ do
+ string "dump-defined-names"
+ return $ toString <$> ((do
+ db <- gets defSiteDB
+ liftIO $ putStrLn $ dumpDefSiteDB db))
+
+cmdDefinedNames :: Command
+cmdDefinedNames =
+ Command $ do
+ string "defined-names"
+ return $ (toString . Lst . definedNames <$> gets defSiteDB)
+
+cmdNameDefinitions :: Command
+cmdNameDefinitions =
+ Command $ do
+ nm <- string "name-definitions" *> sp *> getString
+ return $ toString <$> (do
+ db <- gets defSiteDB
+ let locs = map fst $ lookupDefSite db nm
+ return (Lst locs))
View
@@ -21,6 +21,7 @@ import Exception
import Scion.Types
import Scion.Types.Notes
import Scion.Utils
+import Scion.Inspect.DefinitionSite
import qualified Data.MultiSet as MS
import Control.Monad
@@ -351,7 +352,12 @@ loadComponent comp = do
setComponentDynFlags comp
setComponentTargets comp
rslt <- load LoadAllTargets
- modifySessionState $ \s -> s { lastCompResult = rslt }
+ mg <- getModuleGraph
+ base_dir <- projectRootDir
+ db <- moduleGraphDefSiteDB base_dir mg
+ liftIO $ evaluate db
+ modifySessionState $ \s -> s { lastCompResult = rslt
+ , defSiteDB = db }
return rslt
where
maybe_set_working_dir (File f) = do
@@ -450,7 +456,8 @@ unload :: ScionM ()
unload = do
setTargets []
load LoadAllTargets
- modifySessionState $ \st -> st { lastCompResult = mempty }
+ modifySessionState $ \st -> st { lastCompResult = mempty
+ , defSiteDB = mempty }
return ()
-- | Parses the list of 'Strings' as command line arguments and sets the
@@ -574,7 +581,8 @@ backgroundTypecheckFile fname =
-- TODO: measure time and stop after a phase if it takes too long?
parsed_mod <- parseModule modsum
tcd_mod <- typecheckModule parsed_mod
- _ <- desugarModule tcd_mod
+ ds_mod <- desugarModule tcd_mod
+ loadModule ds_mod -- ensure it's in the HPT
finish_up (Just (Typechecked tcd_mod)) mempty
preprocessModule = do
View
@@ -24,6 +24,7 @@ import HscTypes
import MonadUtils ( liftIO, MonadIO )
import Exception
+import qualified Data.Map as M
import qualified Data.MultiSet as MS
import Distribution.Simple.LocalBuildInfo
import Control.Monad ( when )
@@ -58,13 +59,16 @@ data SessionState
focusedModule :: Maybe ModSummary,
-- ^ The currently focused module for background typechecking.
- bgTcCache :: Maybe BgTcCache
+ bgTcCache :: Maybe BgTcCache,
-- ^ Cached state of the background typechecker.
+
+ defSiteDB :: DefSiteDB
+ -- ^ Source code locations.
}
mkSessionState :: DynFlags -> IO (IORef SessionState)
mkSessionState dflags =
- newIORef (SessionState normal dflags Nothing Nothing mempty Nothing Nothing)
+ newIORef (SessionState normal dflags Nothing Nothing mempty Nothing Nothing mempty)
newtype ScionM a
@@ -237,3 +241,47 @@ data Component
-- | Shorthand for 'undefined'.
__ :: a
__ = undefined
+
+-- * Go To Definition
+
+-- | A definition site database.
+--
+-- This is a map from names to the location of their definition and
+-- information about the defined entity. Note that a name may refer to
+-- multiple entities.
+--
+-- XXX: Currently we use GHC's 'TyThing' data type. However, this probably
+-- holds on to a lot of stuff we don't need. It also cannot be serialised
+-- directly. The reason it's done this way is that wrapping 'TyThing' leads
+-- to a lot of duplicated code. Using a custom type might be useful to have
+-- fewer dependencies on the GHC API; however it also creates problems
+-- mapping things back into GHC API data structures. If we do this, we
+-- should at least remember the 'Unique' in order to quickly look up the
+-- original thing.
+newtype DefSiteDB =
+ DefSiteDB (M.Map String [(Location,TyThing)])
+
+instance Monoid DefSiteDB where
+ mempty = emptyDefSiteDB
+ mappend = unionDefSiteDB
+
+-- | The empty 'DefSiteDB'.
+emptyDefSiteDB :: DefSiteDB
+emptyDefSiteDB = DefSiteDB M.empty
+
+-- | Combine two 'DefSiteDB's. XXX: check for duplicates?
+unionDefSiteDB :: DefSiteDB -> DefSiteDB -> DefSiteDB
+unionDefSiteDB (DefSiteDB m1) (DefSiteDB m2) =
+ DefSiteDB (M.unionWith (++) m1 m2)
+
+-- | Return the list of defined names (the domain) of the 'DefSiteDB'.
+-- The result is, in fact, ordered.
+definedNames :: DefSiteDB -> [String]
+definedNames (DefSiteDB m) = M.keys m
+
+-- | Returns all the entities that the given name may refer to.
+lookupDefSite :: DefSiteDB -> String -> [(Location, TyThing)]
+lookupDefSite (DefSiteDB m) key =
+ case M.lookup key m of
+ Nothing -> []
+ Just xs -> xs
View
@@ -219,6 +219,9 @@ thenCmp x _ = x
-- * Converting from GHC types.
-- | Convert a 'GHC.SrcSpan' to a 'Location'.
+--
+-- The first argument is used to normalise relative source locations to an
+-- absolute file path.
ghcSpanToLocation :: FilePath -- ^ Base directory
-> GHC.SrcSpan
-> Location

0 comments on commit aa6877c

Please sign in to comment.