3
3
{-# LANGUAGE ScopedTypeVariables #-}
4
4
{-# LANGUAGE OverloadedStrings #-}
5
5
{-# LANGUAGE TypeFamilies #-}
6
+ {-# LANGUAGE LambdaCase #-}
6
7
module Haskell.Ide.Engine.Support.HieExtras
7
8
( getDynFlags
8
9
, WithSnippets (.. )
@@ -12,6 +13,7 @@ module Haskell.Ide.Engine.Support.HieExtras
12
13
, getReferencesInDoc
13
14
, getModule
14
15
, findDef
16
+ , findTypeDef
15
17
, showName
16
18
, safeTyThingId
17
19
, PosPrefixInfo (.. )
@@ -28,6 +30,7 @@ import Control.Lens.Prism ( _Just )
28
30
import Control.Lens.Setter ((%~) )
29
31
import Control.Lens.Traversal (traverseOf )
30
32
import Control.Monad.Reader
33
+ import Control.Monad.Except
31
34
import Data.Aeson
32
35
import qualified Data.Aeson.Types as J
33
36
import Data.Char
@@ -476,6 +479,9 @@ getTypeForName n = do
476
479
getSymbolsAtPoint :: Position -> CachedInfo -> [(Range ,Name )]
477
480
getSymbolsAtPoint pos info = maybe [] (`getArtifactsAtPos` locMap info) $ newPosToOld info pos
478
481
482
+ -- | Get a symbol from the given location map at the given location.
483
+ -- Retrieves the name and range of the symbol at the given location
484
+ -- from the cached location map.
479
485
symbolFromTypecheckedModule
480
486
:: LocMap
481
487
-> Position
@@ -538,6 +544,51 @@ getModule df n = do
538
544
539
545
-- ---------------------------------------------------------------------
540
546
547
+ -- | Return the type definition of the symbol at the given position.
548
+ -- Works for Datatypes, Newtypes and Type Definitions, as well as paremterized types.
549
+ -- Type Definitions can only be looked up, if the corresponding type is defined in the project.
550
+ -- Sum Types can also be searched.
551
+ findTypeDef :: Uri -> Position -> IdeDeferM (IdeResult [Location ])
552
+ findTypeDef uri pos = pluginGetFile " findTypeDef: " uri $ \ file ->
553
+ withCachedInfo
554
+ file
555
+ (IdeResultOk [] ) -- Default result
556
+ (\ info -> do
557
+ let rfm = revMap info
558
+ tmap = typeMap info
559
+ oldPos = newPosToOld info pos
560
+
561
+ -- | Get SrcSpan of the name at the given position.
562
+ -- If the old position is Nothing, e.g. there is no cached info about it,
563
+ -- Nothing is returned.
564
+ --
565
+ -- Otherwise, searches for the Type of the given position
566
+ -- and retrieves its SrcSpan.
567
+ getTypeSrcSpanFromPosition
568
+ :: Maybe Position -> ExceptT () IdeDeferM SrcSpan
569
+ getTypeSrcSpanFromPosition maybeOldPosition = do
570
+ oldPosition <- liftMaybe maybeOldPosition
571
+ let tmapRes = getArtifactsAtPos oldPosition tmap
572
+ case tmapRes of
573
+ [] -> throwError ()
574
+ a -> do
575
+ -- take last type since this is always the most accurate one
576
+ tyCon <- liftMaybe $ tyConAppTyCon_maybe (snd $ last a)
577
+ case nameSrcSpan (getName tyCon) of
578
+ UnhelpfulSpan _ -> throwError ()
579
+ realSpan -> return realSpan
580
+
581
+ liftMaybe :: Monad m => Maybe a -> ExceptT () m a
582
+ liftMaybe val = liftEither $ case val of
583
+ Nothing -> Left ()
584
+ Just s -> Right s
585
+
586
+ runExceptT (getTypeSrcSpanFromPosition oldPos) >>= \ case
587
+ Left () -> return $ IdeResultOk []
588
+ Right realSpan ->
589
+ lift $ srcSpanToFileLocation " hare:findTypeDef" rfm realSpan
590
+ )
591
+
541
592
-- | Return the definition
542
593
findDef :: Uri -> Position -> IdeDeferM (IdeResult [Location ])
543
594
findDef uri pos = pluginGetFile " findDef: " uri $ \ file ->
@@ -554,46 +605,53 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file ->
554
605
Just (_, n) ->
555
606
case nameSrcSpan n of
556
607
UnhelpfulSpan _ -> return $ IdeResultOk []
557
- realSpan -> do
558
- res <- srcSpan2Loc rfm realSpan
559
- case res of
560
- Right l@ (J. Location luri range) ->
561
- case uriToFilePath luri of
562
- Nothing -> return $ IdeResultOk [l]
563
- Just fp -> ifCachedModule fp (IdeResultOk [l]) $ \ (_ :: ParsedModule ) info' ->
564
- case oldRangeToNew info' range of
565
- Just r -> return $ IdeResultOk [J. Location luri r]
566
- Nothing -> return $ IdeResultOk [l]
567
- Left x -> do
568
- debugm " findDef: name srcspan not found/valid"
569
- pure (IdeResultFail
570
- (IdeError PluginError
571
- (" hare:findDef" <> " : \" " <> x <> " \" " )
572
- Null )))
573
- where
574
- gotoModule :: (FilePath -> FilePath ) -> ModuleName -> IdeDeferM (IdeResult [Location ])
575
- gotoModule rfm mn = do
576
-
577
- hscEnvRef <- ghcSession <$> readMTS
578
- mHscEnv <- liftIO $ traverse readIORef hscEnvRef
579
-
580
- case mHscEnv of
581
- Just env -> do
582
- fr <- liftIO $ do
583
- -- Flush cache or else we get temporary files
584
- flushFinderCaches env
585
- findImportedModule env mn Nothing
586
- case fr of
587
- Found (ModLocation (Just src) _ _) _ -> do
588
- fp <- reverseMapFile rfm src
589
-
590
- let r = Range (Position 0 0 ) (Position 0 0 )
591
- loc = Location (filePathToUri fp) r
592
- return (IdeResultOk [loc])
593
- _ -> return (IdeResultOk [] )
594
- Nothing -> return $ IdeResultFail
595
- (IdeError PluginError " Couldn't get hscEnv when finding import" Null )
596
-
608
+ realSpan -> lift $ srcSpanToFileLocation " hare:findDef" rfm realSpan
609
+ )
610
+
611
+ -- | Resolve the given SrcSpan to a Location in a file.
612
+ -- Takes the name of the invoking function for error display.
613
+ --
614
+ -- If the SrcSpan can not be resolved, an error will be returned.
615
+ srcSpanToFileLocation :: T. Text -> (FilePath -> FilePath ) -> SrcSpan -> IdeM (IdeResult [Location ])
616
+ srcSpanToFileLocation invoker rfm srcSpan = do
617
+ -- Since we found a real SrcSpan, try to map it to real files
618
+ res <- srcSpan2Loc rfm srcSpan
619
+ case res of
620
+ Right l@ (J. Location luri range) ->
621
+ case uriToFilePath luri of
622
+ Nothing -> return $ IdeResultOk [l]
623
+ Just fp -> ifCachedModule fp (IdeResultOk [l]) $ \ (_ :: ParsedModule ) info' ->
624
+ case oldRangeToNew info' range of
625
+ Just r -> return $ IdeResultOk [J. Location luri r]
626
+ Nothing -> return $ IdeResultOk [l]
627
+ Left x -> do
628
+ debugm (T. unpack invoker <> " : name srcspan not found/valid" )
629
+ pure (IdeResultFail
630
+ (IdeError PluginError
631
+ (invoker <> " : \" " <> x <> " \" " )
632
+ Null ))
633
+
634
+ -- | Goto given module.
635
+ gotoModule :: (FilePath -> FilePath ) -> ModuleName -> IdeDeferM (IdeResult [Location ])
636
+ gotoModule rfm mn = do
637
+ hscEnvRef <- ghcSession <$> readMTS
638
+ mHscEnv <- liftIO $ traverse readIORef hscEnvRef
639
+ case mHscEnv of
640
+ Just env -> do
641
+ fr <- liftIO $ do
642
+ -- Flush cache or else we get temporary files
643
+ flushFinderCaches env
644
+ findImportedModule env mn Nothing
645
+ case fr of
646
+ Found (ModLocation (Just src) _ _) _ -> do
647
+ fp <- reverseMapFile rfm src
648
+
649
+ let r = Range (Position 0 0 ) (Position 0 0 )
650
+ loc = Location (filePathToUri fp) r
651
+ return (IdeResultOk [loc])
652
+ _ -> return (IdeResultOk [] )
653
+ Nothing -> return $ IdeResultFail
654
+ (IdeError PluginError " Couldn't get hscEnv when finding import" Null )
597
655
-- ---------------------------------------------------------------------
598
656
599
657
data HarePoint =
0 commit comments