resolve qualified names using renamed source

lib/Scion/Inspect.hs

@@ -14,7 +14,7 @@
 -- Functionality to inspect Haskell programs.
 --
 module Scion.Inspect 
-  ( typeOfResult, prettyResult, haddockType
+  ( typeOfResult, prettyResult, haddockType, qualifiedResult
   , typeDecls, classDecls, familyDecls
   , toplevelNames, outline, tokensArbitrary, tokenTypesArbitrary
   , module Scion.Inspect.Find
@@ -42,6 +42,7 @@ import DataCon ( dataConUserType )
 import Type ( tidyType )
 import VarEnv ( emptyTidyEnv )
 import GHC.SYB.Utils()
+import qualified Outputable as O ( (<>), empty, dot )
 
 import Data.Data
 import Data.Generics.Biplate
@@ -79,7 +80,16 @@ prettyResult (FoundName n) = ppr n
 prettyResult (FoundCon _ c) = ppr c
 prettyResult r = ppr r
 
-haddockType  :: SearchResult Id -> String
+qualifiedResult :: OutputableBndr id => SearchResult id -> SDoc
+qualifiedResult (FoundId i) = qualifiedName $ getName  i
+qualifiedResult (FoundName n) = qualifiedName n
+qualifiedResult (FoundCon _ c) = qualifiedName $ getName c
+qualifiedResult r = ppr r
+
+qualifiedName :: Name -> SDoc
+qualifiedName n = maybe O.empty  (\x-> (ppr x) O.<> O.dot) (nameModule_maybe n) O.<> (ppr n)
+
+haddockType  :: SearchResult a -> String
 haddockType (FoundName n)
         | isValOcc (nameOccName n)="v"
         | otherwise= "t"

lib/Scion/Inspect/Find.hs

@@ -13,7 +13,7 @@
 -- Find things in a syntax tree.
 --
 module Scion.Inspect.Find 
-  ( findHsThing, SearchResult(..), SearchResults
+  ( findHsThing, SearchResult(..), SearchResults, Search
   , PosTree(..), PosForest, deepestLeaf, pathToDeepest
   , surrounds, overlaps
 #ifdef SCION_DEBUG
@@ -263,6 +263,12 @@ instance (Search id arg, Search id rec) => Search id (HsConDetails arg rec) wher
   search p s (RecCon rec)     = search p s rec
   search p s (InfixCon a1 a2) = search p s a1 `mappend` search p s a2
 
+--instance (Search id id) => Search id  (HsModule id) where
+--  search p s m =search p s (hsmodDecls m)
+
+instance Search Name (RenamedSource) where
+  search p s (b,_,_,_) = search p s b
+
 instance (Search id id) => Search id (HsType id) where
   search _ s t = only (FoundType s t)
 

lib/Test/InspectTest.hs

@@ -3,19 +3,25 @@ module Test.InspectTest where
 
 import Scion
 import Scion.Inspect
+import Scion.Types
 import Scion.Types.Notes
 import Scion.Types.Outline
+import Scion.Session
 
 import Text.JSON.AttoJSON
+import FastString
+import SrcLoc
+import Scion.Ghc hiding ( (<+>) )
 
 import System.Directory
 import System.FilePath
 import qualified Data.ByteString.Char8 as S
 import Test.HUnit
+import qualified Outputable as O ( (<+>),alwaysQualify,neverQualify,text )
 
 inspectTests :: Test
 inspectTests=TestList [testTokenTypesSimple,testTokenTypesPreproc,testTokenTypesPreproc2Lines,testTokenTypesLiteral,
-        testNoPreproc,testPreproc,testPreproc2Lines,testLiterate]
+        testNoPreproc,testPreproc,testPreproc2Lines,testLiterate,testResolveFunctionWithTypeClass,testResolveFunctionWithoutTypeClass]
 
 
 testTokenTypesSimple :: Test
@@ -127,3 +133,39 @@ perf = do
         case r of 
                 Left n -> putStrLn (show n)
                 Right tts-> putStrLn (show $ length $ tts)
+
+testResolveFunctionWithTypeClass :: Test
+testResolveFunctionWithTypeClass  = TestLabel "testResolveFunctionWithTypeClass" (TestCase (do
+        r<-functionAtLine 12
+        assertEqual "" "TestR.f2 v" r
+        )) 
+
+testResolveFunctionWithoutTypeClass :: Test
+testResolveFunctionWithoutTypeClass  = TestLabel "testResolveFunctionWithoutTypeClass" (TestCase (do
+        r<-functionAtLine 11
+        assertEqual "" "TestR.f1 v" r
+        ))         
+
+functionAtLine :: Int -> IO (String)
+functionAtLine line=do
+        base_dir <- getCurrentDirectory
+        let file= base_dir </> "tests" </> "TestR.hs"
+        r<-runScion $ do
+                loadComponent' (Component $ FileComp file) (LoadOptions False False)
+                backgroundTypecheckFile file
+                let loc = srcLocSpan $ mkSrcLoc (fsLit file) line 13
+                tc_res <- gets bgTcCache
+                let s= showSDocForUser O.neverQualify  --showSDocDebug
+                l<-case tc_res of
+                        Just (Typechecked tcm) -> do
+                            let psrc= renamedSource tcm
+                            let in_range = overlaps loc
+                            let r = findHsThing in_range psrc
+                            return $ case pathToDeepest r of
+                              Nothing -> ""
+                              Just (x,l1) -> (s  $ ((qualifiedResult x)O.<+> (O.text $ haddockType x)))   -- ++"->"++ (concat $ map (("\n\t" ++) . s . ppr) l1)
+                        Nothing -> return ""
+                return l
+        setCurrentDirectory base_dir
+        return r
+

server/Scion/Server/Commands.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards, 
-             ExistentialQuantification #-} -- for 'Cmd'
+{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards, FlexibleContexts,
+             ExistentialQuantification  #-} -- for 'Cmd'
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- |
 -- Module      : Scion.Server.Commands
@@ -38,7 +38,7 @@ import DynFlags ( supportedLanguages, allFlags )
 import Exception
 import FastString
 import PprTyThing ( pprTypeForUser )
-import qualified Outputable as O ( (<+>),alwaysQualify,text )
+import qualified Outputable as O ( (<+>),alwaysQualify,neverQualify,text )
 
 import Control.Applicative
 import Data.List ( nub )
@@ -511,43 +511,45 @@ cmdThingAtPoint =
     cmd fname line col qual typed= do
       let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
       tc_res <- gets bgTcCache
-      -- TODO: don't return something of type @Maybe X@.  The default
-      -- serialisation sucks.
       case tc_res of
         Just (Typechecked tcm) -> do
-            --let Just (src, _, _, _, _) = renamedSource tcm
-            let src = typecheckedSource tcm
-            --let in_range = const True
+             let f=(if typed then (doThingAtPointTyped $ typecheckedSource tcm) else (doThingAtPointUntyped $ renamedSource tcm))
+             --tap<- doThingAtPoint loc qual typed tcm (if typed then (typecheckedSource tcm) else (renamedSource tcm))
+             tap<-f loc qual tcm
+                --(if typed then (doThingAtPointTyped $ typecheckedSource tcm) 
+               -- else doThingAtPointTyped (renamedSource tcm) loc qual tcm
+             return $ Just tap
+        _ -> return Nothing
+    doThingAtPointTyped :: Search Id a => a ->  SrcSpan -> Bool -> TypecheckedModule -> ScionM String
+    doThingAtPointTyped src loc qual tcm=do
             let in_range = overlaps loc
             let r = findHsThing in_range src
-            --return (Just (showSDoc (ppr $ S.toList r)))
             unqual <- if qual
                 then return $ O.alwaysQualify
                 else unqualifiedForModule tcm
             return $ case pathToDeepest r of
-              Nothing -> (Just "no info")
+              Nothing -> "no info"
               Just (x,xs) ->
-                if typed
-                        then
-                                --return $ Just (showSDoc (ppr x O.$$ ppr xs))
-                                case typeOf (x,xs) of
-                                  Just t ->
-                                      Just $ showSDocForUser unqual
-                                        (prettyResult x O.<+> dcolon O.<+> 
-                                          pprTypeForUser True t)
-                                  _ -> Just $ showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x O.$$ ppr xs )))
-                        else Just $ showSDocForUser unqual ((prettyResult x) O.<+> (O.text $ haddockType x))
-        _ -> return Nothing
-
-
--- Haddock: Haddock.Backend.Xhtml.Utils.spliceURL                    
---                    (name, kind) =
---    case maybe_name of
---      Nothing             -> ("","")
---      Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
---             | otherwise -> (escapeStr (getOccString n), "t")  
-
-
+                case typeOf (x,xs) of
+                  Just t ->
+                      showSDocForUser unqual
+                        (prettyResult x O.<+> dcolon O.<+> 
+                          pprTypeForUser True t)
+                  _ -> showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x O.$$ ppr xs )))
+    doThingAtPointUntyped :: (Search id a, OutputableBndr id) => a -> SrcSpan -> Bool -> TypecheckedModule  -> ScionM String
+    doThingAtPointUntyped src loc qual tcm =do
+            let in_range = overlaps loc
+            let r = findHsThing in_range src
+            unqual <- if qual
+                then return $ O.neverQualify
+                else unqualifiedForModule tcm
+            return $ case pathToDeepest r of
+              Nothing -> "no info"
+              Just (x,_) ->
+                if qual
+                        then showSDocForUser unqual ((qualifiedResult x) O.<+> (O.text $ haddockType x))
+                        else showSDocForUser unqual ((prettyResult x) O.<+> (O.text $ haddockType x))         
+
 cmdToplevelNames :: Cmd
 cmdToplevelNames=
      Cmd "top-level-names" $ noArgs $ cmd

tests/TestR.hs

@@ -0,0 +1,13 @@
+module TestR
+where
+
+f1 :: String -> String
+f1 = undefined
+
+f2 :: Ord a => a-> a
+f2 = undefined
+
+main=let
+        r1=f1 "titi"
+        r2=f2 "toto"
+     in r2