mirror of
https://github.com/haskell/haskell-ide-engine.git
synced 2024-09-11 11:05:30 +03:00
Merge pull request https://github.com/mpickering/haskell-ide-engine/pull/78 from alanz/hie-bios-no-hare
Remove HaRe dependency from HIE.
This commit is contained in:
fendor
GitHub
commit
43cf0d1d3e
4
.gitmodules
vendored
4
.gitmodules
vendored
@ -10,10 +10,6 @@
|
||||
# rm -rf path_to_submodule
|
||||
|
||||
|
||||
[submodule "submodules/HaRe"]
|
||||
path = submodules/HaRe
|
||||
url = https://github.com/alanz/HaRe.git
|
||||
|
||||
[submodule "submodules/cabal-helper"]
|
||||
path = submodules/cabal-helper
|
||||
# url = https://github.com/DanielG/cabal-helper.git
|
||||
|
||||
@ -28,7 +28,7 @@ import Haskell.Ide.Engine.Plugin.Base
|
||||
import Haskell.Ide.Engine.Plugin.Brittany
|
||||
import Haskell.Ide.Engine.Plugin.Example2
|
||||
import Haskell.Ide.Engine.Plugin.Bios
|
||||
import Haskell.Ide.Engine.Plugin.HaRe
|
||||
-- import Haskell.Ide.Engine.Plugin.HaRe
|
||||
import Haskell.Ide.Engine.Plugin.Haddock
|
||||
import Haskell.Ide.Engine.Plugin.HfaAlign
|
||||
import Haskell.Ide.Engine.Plugin.Hoogle
|
||||
@ -53,7 +53,7 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins
|
||||
, baseDescriptor "base"
|
||||
, brittanyDescriptor "brittany"
|
||||
, haddockDescriptor "haddock"
|
||||
, hareDescriptor "hare"
|
||||
-- , hareDescriptor "hare"
|
||||
, hoogleDescriptor "hoogle"
|
||||
, hsimportDescriptor "hsimport"
|
||||
, liquidDescriptor "liquid"
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
packages:
|
||||
./
|
||||
./hie-plugin-api/
|
||||
./hie-bios/
|
||||
./hie-bios/
|
||||
|
||||
./submodules/HaRe
|
||||
-- ./submodules/HaRe
|
||||
./submodules/cabal-helper/
|
||||
./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -30,7 +30,7 @@ library
|
||||
Haskell.Ide.Engine.Plugin.Example2
|
||||
Haskell.Ide.Engine.Plugin.Floskell
|
||||
Haskell.Ide.Engine.Plugin.Bios
|
||||
Haskell.Ide.Engine.Plugin.HaRe
|
||||
-- Haskell.Ide.Engine.Plugin.HaRe
|
||||
Haskell.Ide.Engine.Plugin.Haddock
|
||||
Haskell.Ide.Engine.Plugin.HfaAlign
|
||||
Haskell.Ide.Engine.Plugin.Hoogle
|
||||
@ -41,6 +41,7 @@ library
|
||||
Haskell.Ide.Engine.Plugin.Pragmas
|
||||
Haskell.Ide.Engine.Plugin.Generic
|
||||
Haskell.Ide.Engine.Scheduler
|
||||
Haskell.Ide.Engine.Support.FromHaRe
|
||||
Haskell.Ide.Engine.Support.Fuzzy
|
||||
Haskell.Ide.Engine.Support.HieExtras
|
||||
Haskell.Ide.Engine.Transport.JsonStdio
|
||||
@ -49,7 +50,7 @@ library
|
||||
other-modules: Paths_haskell_ide_engine
|
||||
build-depends: Cabal >= 1.22
|
||||
, Diff
|
||||
, HaRe
|
||||
-- , HaRe
|
||||
, aeson
|
||||
, apply-refact
|
||||
, async
|
||||
@ -87,6 +88,7 @@ library
|
||||
, safe
|
||||
, sorted-list >= 0.2.1.0
|
||||
, stm
|
||||
, syb
|
||||
, tagsoup
|
||||
, text
|
||||
, transformers
|
||||
@ -181,7 +183,7 @@ test-suite unit-test
|
||||
DiffSpec
|
||||
ExtensibleStateSpec
|
||||
GhcModPluginSpec
|
||||
HaRePluginSpec
|
||||
-- HaRePluginSpec
|
||||
HooglePluginSpec
|
||||
JsonSpec
|
||||
LiquidSpec
|
||||
@ -273,7 +275,7 @@ test-suite func-test
|
||||
, FunctionalCodeActionsSpec
|
||||
, FunctionalLiquidSpec
|
||||
, FunctionalSpec
|
||||
, HaReSpec
|
||||
-- , HaReSpec
|
||||
, HieBiosSpec
|
||||
, HighlightSpec
|
||||
, HoverSpec
|
||||
|
||||
@ -39,7 +39,7 @@ import Var
|
||||
import Packages (listVisibleModuleNames)
|
||||
|
||||
|
||||
import Language.Haskell.Refact.API ( showGhc )
|
||||
-- import Language.Haskell.Refact.API ( showGhc )
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Capabilities
|
||||
@ -58,6 +58,10 @@ import Haskell.Ide.Engine.MonadTypes
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import Haskell.Ide.Engine.Context
|
||||
|
||||
import Language.Haskell.GHC.ExactPrint.Utils
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data CompItem = CI
|
||||
{ origName :: Name -- ^ Original name, such as Maybe, //, or find.
|
||||
, importedFrom :: T.Text -- ^ From where this item is imported from.
|
||||
|
||||
@ -21,12 +21,13 @@ import GHC.Generics
|
||||
import Haskell.Ide.Engine.MonadFunctions
|
||||
import Haskell.Ide.Engine.MonadTypes
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import Haskell.Ide.Engine.Support.FromHaRe
|
||||
import qualified Haskell.Ide.Engine.GhcCompat as C ( GhcPs )
|
||||
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
|
||||
import Haskell.Ide.Engine.ArtifactMap
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
import qualified Language.Haskell.LSP.Types.Lens as LSP
|
||||
import Language.Haskell.Refact.API (hsNamessRdr)
|
||||
-- import Language.Haskell.Refact.API (hsNamessRdr)
|
||||
import HIE.Bios.Ghc.Doc
|
||||
|
||||
import GHC
|
||||
|
||||
@ -1,327 +0,0 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Haskell.Ide.Engine.Plugin.HaRe where
|
||||
|
||||
import Control.Lens.Operators
|
||||
import Control.Monad.State
|
||||
-- import Control.Monad.Trans.Control
|
||||
import Data.Aeson
|
||||
import qualified Data.Aeson.Types as J
|
||||
import Data.Algorithm.Diff
|
||||
import Data.Algorithm.DiffOutput
|
||||
import Data.Foldable
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Exception
|
||||
import GHC.Generics (Generic)
|
||||
import Haskell.Ide.Engine.ArtifactMap
|
||||
import Haskell.Ide.Engine.MonadFunctions
|
||||
import Haskell.Ide.Engine.MonadTypes
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
|
||||
import Language.Haskell.GHC.ExactPrint.Print
|
||||
import qualified Language.Haskell.LSP.Core as Core
|
||||
import Language.Haskell.LSP.VFS
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
import Language.Haskell.Refact.API hiding (logm)
|
||||
import Language.Haskell.Refact.HaRe
|
||||
import Language.Haskell.Refact.Utils.Monad hiding (logm)
|
||||
import qualified Data.Rope.UTF16 as Rope
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
hareDescriptor :: PluginId -> PluginDescriptor
|
||||
hareDescriptor plId = PluginDescriptor
|
||||
{ pluginId = plId
|
||||
, pluginName = "HaRe"
|
||||
, pluginDesc = "A Haskell 2010 refactoring tool. HaRe supports the full "
|
||||
<> "Haskell 2010 standard, through making use of the GHC API. HaRe attempts to "
|
||||
<> "operate in a safe way, by first writing new files with proposed changes, and "
|
||||
<> "only swapping these with the originals when the change is accepted. "
|
||||
, pluginCommands =
|
||||
[ PluginCommand "demote" "Move a definition one level down"
|
||||
demoteCmd
|
||||
, PluginCommand "dupdef" "Duplicate a definition"
|
||||
dupdefCmd
|
||||
, PluginCommand "iftocase" "Converts an if statement to a case statement"
|
||||
iftocaseCmd
|
||||
, PluginCommand "liftonelevel" "Move a definition one level up from where it is now"
|
||||
liftonelevelCmd
|
||||
, PluginCommand "lifttotoplevel" "Move a definition to the top level from where it is now"
|
||||
lifttotoplevelCmd
|
||||
, PluginCommand "rename" "rename a variable or type"
|
||||
renameCmd
|
||||
, PluginCommand "deletedef" "Delete a definition"
|
||||
deleteDefCmd
|
||||
, PluginCommand "genapplicative" "Generalise a monadic function to use applicative"
|
||||
genApplicativeCommand
|
||||
|
||||
]
|
||||
, pluginCodeActionProvider = Just codeActionProvider
|
||||
, pluginDiagnosticProvider = Nothing
|
||||
, pluginHoverProvider = Nothing
|
||||
, pluginSymbolProvider = Nothing
|
||||
, pluginFormattingProvider = Nothing
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data HarePointWithText =
|
||||
HPT { hptFile :: Uri
|
||||
, hptPos :: Position
|
||||
, hptText :: T.Text
|
||||
} deriving (Eq,Generic,Show)
|
||||
|
||||
instance FromJSON HarePointWithText where
|
||||
parseJSON = genericParseJSON $ Hie.customOptions 3
|
||||
instance ToJSON HarePointWithText where
|
||||
toJSON = genericToJSON $ Hie.customOptions 3
|
||||
|
||||
data HareRange =
|
||||
HR { hrFile :: Uri
|
||||
, hrStartPos :: Position
|
||||
, hrEndPos :: Position
|
||||
} deriving (Eq,Generic,Show)
|
||||
|
||||
instance FromJSON HareRange where
|
||||
parseJSON = genericParseJSON $ Hie.customOptions 2
|
||||
instance ToJSON HareRange where
|
||||
toJSON = genericToJSON $ Hie.customOptions 2
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
|
||||
demoteCmd = CmdSync $ \(Hie.HP uri pos) ->
|
||||
demoteCmd' uri pos
|
||||
|
||||
demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
demoteCmd' uri pos =
|
||||
pluginGetFile "demote: " uri $ \file ->
|
||||
runHareCommand "demote" (compDemote file (unPos pos))
|
||||
|
||||
-- compDemote :: FilePath -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
dupdefCmd :: CommandFunc HarePointWithText WorkspaceEdit
|
||||
dupdefCmd = CmdSync $ \(HPT uri pos name) ->
|
||||
dupdefCmd' uri pos name
|
||||
|
||||
dupdefCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
dupdefCmd' uri pos name =
|
||||
pluginGetFile "dupdef: " uri $ \file ->
|
||||
runHareCommand "dupdef" (compDuplicateDef file (T.unpack name) (unPos pos))
|
||||
|
||||
-- compDuplicateDef :: FilePath -> String -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
iftocaseCmd :: CommandFunc HareRange WorkspaceEdit
|
||||
iftocaseCmd = CmdSync $ \(HR uri startPos endPos) ->
|
||||
iftocaseCmd' uri (Range startPos endPos)
|
||||
|
||||
iftocaseCmd' :: Uri -> Range -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
iftocaseCmd' uri (Range startPos endPos) =
|
||||
pluginGetFile "iftocase: " uri $ \file ->
|
||||
runHareCommand "iftocase" (compIfToCase file (unPos startPos) (unPos endPos))
|
||||
|
||||
-- compIfToCase :: FilePath -> SimpPos -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
|
||||
liftonelevelCmd = CmdSync $ \(Hie.HP uri pos) ->
|
||||
liftonelevelCmd' uri pos
|
||||
|
||||
liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
liftonelevelCmd' uri pos =
|
||||
pluginGetFile "liftonelevelCmd: " uri $ \file ->
|
||||
runHareCommand "liftonelevel" (compLiftOneLevel file (unPos pos))
|
||||
|
||||
-- compLiftOneLevel :: FilePath -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
|
||||
lifttotoplevelCmd = CmdSync $ \(Hie.HP uri pos) ->
|
||||
lifttotoplevelCmd' uri pos
|
||||
|
||||
lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
lifttotoplevelCmd' uri pos =
|
||||
pluginGetFile "lifttotoplevelCmd: " uri $ \file ->
|
||||
runHareCommand "lifttotoplevel" (compLiftToTopLevel file (unPos pos))
|
||||
|
||||
-- compLiftToTopLevel :: FilePath -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
renameCmd :: CommandFunc HarePointWithText WorkspaceEdit
|
||||
renameCmd = CmdSync $ \(HPT uri pos name) ->
|
||||
renameCmd' uri pos name
|
||||
|
||||
renameCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
renameCmd' uri pos name =
|
||||
pluginGetFile "rename: " uri $ \file ->
|
||||
runHareCommand "rename" (compRename file (T.unpack name) (unPos pos))
|
||||
|
||||
-- compRename :: FilePath -> String -> SimpPos -> IO [FilePath]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
|
||||
deleteDefCmd = CmdSync $ \(Hie.HP uri pos) ->
|
||||
deleteDefCmd' uri pos
|
||||
|
||||
deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
deleteDefCmd' uri pos =
|
||||
pluginGetFile "deletedef: " uri $ \file ->
|
||||
runHareCommand "deltetedef" (compDeleteDef file (unPos pos))
|
||||
|
||||
-- compDeleteDef ::FilePath -> SimpPos -> RefactGhc [ApplyRefacResult]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit
|
||||
genApplicativeCommand = CmdSync $ \(Hie.HP uri pos) ->
|
||||
genApplicativeCommand' uri pos
|
||||
|
||||
genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
genApplicativeCommand' uri pos =
|
||||
pluginGetFile "genapplicative: " uri $ \file ->
|
||||
runHareCommand "genapplicative" (compGenApplicative file (unPos pos))
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
getRefactorResult :: [ApplyRefacResult] -> [(FilePath,T.Text)]
|
||||
getRefactorResult = map getNewFile . filter fileModified
|
||||
where fileModified ((_,m),_) = m == RefacModified
|
||||
getNewFile ((file,_),(ann, parsed)) = (file, T.pack $ exactPrint parsed ann)
|
||||
|
||||
makeRefactorResult :: [(FilePath,T.Text)] -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
makeRefactorResult changedFiles = do
|
||||
let
|
||||
diffOne :: (FilePath, T.Text) -> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
diffOne (fp, newText) = do
|
||||
uri <- canonicalizeUri $ filePathToUri fp
|
||||
mvf <- getVirtualFile uri
|
||||
|
||||
origTextResult <- case mvf of
|
||||
Nothing -> do
|
||||
let defaultResult = do
|
||||
debugm "makeRefactorResult: no access to the persisted file."
|
||||
return $ IdeResultOk mempty
|
||||
|
||||
withMappedFile fp defaultResult (fmap IdeResultOk . liftIO . T.readFile)
|
||||
Just vf -> return $ IdeResultOk $ Rope.toText $ _text vf
|
||||
|
||||
case origTextResult of
|
||||
IdeResultFail err -> do
|
||||
logm "makeRefactorResult:could not retrieve original text"
|
||||
return $ IdeResultFail err
|
||||
IdeResultOk origText -> do
|
||||
-- TODO: remove this logging once we are sure we have a working solution
|
||||
logm $ "makeRefactorResult:groupedDiff = " ++ show (getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText))
|
||||
logm $ "makeRefactorResult:diffops = " ++ show (diffToLineRanges $ getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText))
|
||||
liftToGhc $ IdeResultOk <$> diffText (filePathToUri fp, origText) newText IncludeDeletions
|
||||
|
||||
diffResults <- mapM diffOne changedFiles
|
||||
let diffs = sequenceA diffResults
|
||||
case diffs of
|
||||
IdeResultOk diffs' -> return $ IdeResultOk $ Core.reverseSortEdit $ fold diffs'
|
||||
IdeResultFail err -> return $ IdeResultFail err
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
runHareCommand :: String -> RefactGhc [ApplyRefacResult]
|
||||
-> IdeGhcM (IdeResult WorkspaceEdit)
|
||||
runHareCommand name cmd = do
|
||||
eitherRes <- runHareCommand' cmd
|
||||
case eitherRes of
|
||||
Left err ->
|
||||
pure (IdeResultFail
|
||||
(IdeError PluginError
|
||||
(T.pack $ name <> ": \"" <> err <> "\"")
|
||||
Null))
|
||||
Right res -> do
|
||||
let changes = getRefactorResult res
|
||||
makeRefactorResult changes
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
-- newtype RefactGhc a = RefactGhc
|
||||
-- { unRefactGhc :: StateT RefactState HIE.IdeGhcM a
|
||||
-- }
|
||||
|
||||
runHareCommand' :: forall a. RefactGhc a
|
||||
-> IdeGhcM (Either String a)
|
||||
runHareCommand' cmd =
|
||||
do let initialState =
|
||||
-- TODO: Make this a command line flag
|
||||
RefSt {rsSettings = defaultSettings
|
||||
-- RefSt {rsSettings = logSettings
|
||||
,rsUniqState = 1
|
||||
,rsSrcSpanCol = 1
|
||||
,rsFlags = RefFlags False
|
||||
,rsStorage = StorageNone
|
||||
,rsCurrentTarget = Nothing
|
||||
,rsModule = Nothing}
|
||||
let
|
||||
cmd' :: StateT RefactState IdeGhcM a
|
||||
cmd' = unRefactGhc cmd
|
||||
embeddedCmd =
|
||||
evalStateT cmd' initialState
|
||||
handlers
|
||||
:: Applicative m
|
||||
=> [ErrorHandler m (Either String a)]
|
||||
handlers =
|
||||
[ErrorHandler (\(ErrorCall e) -> pure (Left e))]
|
||||
fmap Right embeddedCmd `gcatches` handlers
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
codeActionProvider :: CodeActionProvider
|
||||
codeActionProvider pId docId (J.Range pos _) _ =
|
||||
pluginGetFile "HaRe codeActionProvider: " (docId ^. J.uri) $ \file ->
|
||||
ifCachedInfo file (IdeResultOk mempty) $ \info ->
|
||||
case getArtifactsAtPos pos (defMap info) of
|
||||
[h] -> do
|
||||
let name = Hie.showName $ snd h
|
||||
debugm $ show name
|
||||
IdeResultOk <$> sequence [
|
||||
mkAction "liftonelevel"
|
||||
J.CodeActionRefactorExtract $ "Lift " <> name <> " one level"
|
||||
, mkAction "lifttotoplevel"
|
||||
J.CodeActionRefactorExtract $ "Lift " <> name <> " to top level"
|
||||
, mkAction "demote"
|
||||
J.CodeActionRefactorInline $ "Demote " <> name <> " one level"
|
||||
, mkAction "deletedef"
|
||||
J.CodeActionRefactor $ "Delete definition of " <> name
|
||||
, mkHptAction "dupdef"
|
||||
J.CodeActionRefactor "Duplicate definition of " name
|
||||
]
|
||||
_ -> case getArtifactsAtPos pos (locMap info) of
|
||||
-- TODO: disabled casesplit command
|
||||
-- TODO: @fendor: add github issue link
|
||||
-- [h] -> do
|
||||
-- let name = Hie.showName $ snd h
|
||||
-- IdeResultOk <$> sequence [
|
||||
-- mkAction "casesplit"
|
||||
-- J.CodeActionRefactorRewrite $ "Case split on " <> name
|
||||
-- ]
|
||||
_ -> return $ IdeResultOk []
|
||||
where
|
||||
mkAction aId kind title = do
|
||||
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
|
||||
cmd <- mkLspCommand pId aId title (Just args)
|
||||
return $ J.CodeAction title (Just kind) mempty Nothing (Just cmd)
|
||||
|
||||
mkHptAction aId kind title name = do
|
||||
let args = [J.toJSON $ HPT (docId ^. J.uri) pos (name <> "'")]
|
||||
cmd <- mkLspCommand pId aId title (Just args)
|
||||
return $ J.CodeAction (title <> name) (Just kind) mempty Nothing (Just cmd)
|
||||
221
src/Haskell/Ide/Engine/Support/FromHaRe.hs
Normal file
221
src/Haskell/Ide/Engine/Support/FromHaRe.hs
Normal file
@ -0,0 +1,221 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Haskell.Ide.Engine.Support.FromHaRe
|
||||
(
|
||||
initRdrNameMap
|
||||
, NameMap
|
||||
, hsNamessRdr
|
||||
) where
|
||||
|
||||
-- Code migrated from HaRe, until HaRe comes back
|
||||
|
||||
-- import Control.Monad.State
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
import qualified GHC as GHC
|
||||
-- import qualified GhcMonad as GHC
|
||||
-- import qualified Haskell.Ide.Engine.PluginApi as HIE (makeRevRedirMapFunc)
|
||||
import qualified Module as GHC
|
||||
import qualified Name as GHC
|
||||
import qualified Unique as GHC
|
||||
-- import qualified HscTypes as GHC (md_exports)
|
||||
-- import qualified TcRnTypes as GHC (tcg_rdr_env)
|
||||
#if __GLASGOW_HASKELL__ > 710
|
||||
import qualified Var
|
||||
#endif
|
||||
|
||||
import qualified Data.Generics as SYB
|
||||
|
||||
-- import Language.Haskell.GHC.ExactPrint
|
||||
-- import Language.Haskell.GHC.ExactPrint.Annotate
|
||||
-- import Language.Haskell.GHC.ExactPrint.Parsers
|
||||
import Language.Haskell.GHC.ExactPrint.Utils
|
||||
import Language.Haskell.GHC.ExactPrint.Types
|
||||
|
||||
-- import Language.Haskell.Refact.Utils.Monad
|
||||
-- import Language.Haskell.Refact.Utils.TypeSyn
|
||||
-- import Language.Haskell.Refact.Utils.Types
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- import Outputable
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
type NameMap = Map.Map GHC.SrcSpan GHC.Name
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
-- |We need the ParsedSource because it more closely reflects the actual source
|
||||
-- code, but must be able to work with the renamed representation of the names
|
||||
-- involved. This function constructs a map from every Located RdrName in the
|
||||
-- ParsedSource to its corresponding name in the RenamedSource. It also deals
|
||||
-- with the wrinkle that we need to Location of the RdrName to make sure we have
|
||||
-- the right Name, but not all RdrNames have a Location.
|
||||
-- This function is called before the RefactGhc monad is active.
|
||||
initRdrNameMap :: GHC.TypecheckedModule -> NameMap
|
||||
initRdrNameMap tm = r
|
||||
where
|
||||
parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module tm
|
||||
renamed = GHC.tm_renamed_source tm
|
||||
#if __GLASGOW_HASKELL__ > 710
|
||||
typechecked = GHC.tm_typechecked_source tm
|
||||
#endif
|
||||
|
||||
checkRdr :: GHC.Located GHC.RdrName -> Maybe [(GHC.SrcSpan,GHC.RdrName)]
|
||||
checkRdr (GHC.L l n@(GHC.Unqual _)) = Just [(l,n)]
|
||||
checkRdr (GHC.L l n@(GHC.Qual _ _)) = Just [(l,n)]
|
||||
checkRdr (GHC.L _ _)= Nothing
|
||||
|
||||
checkName :: GHC.Located GHC.Name -> Maybe [GHC.Located GHC.Name]
|
||||
checkName ln = Just [ln]
|
||||
|
||||
rdrNames = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkRdr ) parsed
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
names1 = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
|
||||
names2 = names1 ++ SYB.everything (++) ([] `SYB.mkQ` fieldOcc
|
||||
`SYB.extQ` hsRecFieldN) renamed
|
||||
names = names2 ++ SYB.everything (++) ([] `SYB.mkQ` hsRecFieldT) typechecked
|
||||
|
||||
fieldOcc :: GHC.FieldOcc GhcRn -> [GHC.Located GHC.Name]
|
||||
fieldOcc (GHC.FieldOcc n (GHC.L l _)) = [(GHC.L l n)]
|
||||
fieldOcc (GHC.XFieldOcc _) = []
|
||||
|
||||
hsRecFieldN :: GHC.LHsExpr GhcRn -> [GHC.Located GHC.Name]
|
||||
hsRecFieldN (GHC.L _ (GHC.HsRecFld _ (GHC.Unambiguous n (GHC.L l _) ) )) = [GHC.L l n]
|
||||
hsRecFieldN _ = []
|
||||
|
||||
hsRecFieldT :: GHC.LHsExpr GhcTc -> [GHC.Located GHC.Name]
|
||||
hsRecFieldT (GHC.L _ (GHC.HsRecFld _ (GHC.Ambiguous n (GHC.L l _)) )) = [GHC.L l (Var.varName n)]
|
||||
hsRecFieldT _ = []
|
||||
#elif __GLASGOW_HASKELL__ > 710
|
||||
names1 = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
|
||||
names2 = names1 ++ SYB.everything (++) ([] `SYB.mkQ` fieldOcc
|
||||
`SYB.extQ` hsRecFieldN) renamed
|
||||
names = names2 ++ SYB.everything (++) ([] `SYB.mkQ` hsRecFieldT) typechecked
|
||||
|
||||
fieldOcc :: GHC.FieldOcc GhcRn -> [GHC.Located GHC.Name]
|
||||
fieldOcc (GHC.FieldOcc (GHC.L l _) n) = [(GHC.L l n)]
|
||||
|
||||
hsRecFieldN :: GHC.LHsExpr GhcRn -> [GHC.Located GHC.Name]
|
||||
hsRecFieldN (GHC.L _ (GHC.HsRecFld (GHC.Unambiguous (GHC.L l _) n) )) = [GHC.L l n]
|
||||
hsRecFieldN _ = []
|
||||
|
||||
hsRecFieldT :: GHC.LHsExpr GhcTc -> [GHC.Located GHC.Name]
|
||||
hsRecFieldT (GHC.L _ (GHC.HsRecFld (GHC.Ambiguous (GHC.L l _) n) )) = [GHC.L l (Var.varName n)]
|
||||
hsRecFieldT _ = []
|
||||
#else
|
||||
names = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
namesIe = names
|
||||
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)))
|
||||
-- This is a workaround for https://ghc.haskell.org/trac/ghc/ticket/14189
|
||||
-- namesIeParsedL = SYB.everything (++) ([] `SYB.mkQ` ieThingWith) (GHC.hsmodExports $ GHC.unLoc parsed)
|
||||
namesIeParsed = Map.fromList $ SYB.everything (++) ([] `SYB.mkQ` ieThingWith) (GHC.hsmodExports $ GHC.unLoc parsed)
|
||||
|
||||
|
||||
ieThingWith :: GHC.IE GhcPs -> [(GHC.SrcSpan, [GHC.SrcSpan])]
|
||||
ieThingWith (GHC.IEThingWith l _ sub_rdrs _) = [(GHC.getLoc l,map GHC.getLoc sub_rdrs)]
|
||||
ieThingWith _ = []
|
||||
|
||||
renamedExports = case renamed of
|
||||
Nothing -> Nothing
|
||||
Just (_,_,es,_) -> es
|
||||
namesIeRenamed = SYB.everything (++) ([] `SYB.mkQ` ieThingWithNames) renamedExports
|
||||
|
||||
ieThingWithNames :: GHC.IE GhcRn -> [GHC.Located GHC.Name]
|
||||
ieThingWithNames (GHC.IEThingWith l _ sub_rdrs _) = (GHC.ieLWrappedName l:nameSubs)
|
||||
where
|
||||
rdrSubLocs = gfromJust "ieThingWithNames" $ Map.lookup (GHC.getLoc l) namesIeParsed
|
||||
nameSubs = map (\(loc,GHC.L _ lwn) -> GHC.L loc (GHC.ieWrappedName lwn)) $ zip rdrSubLocs sub_rdrs
|
||||
ieThingWithNames _ = []
|
||||
|
||||
namesIe = case SYB.everything mappend (nameSybQuery checkName) namesIeRenamed of
|
||||
Nothing -> names
|
||||
Just ns -> names ++ ns
|
||||
#else
|
||||
namesIe = names
|
||||
#endif
|
||||
|
||||
nameMap = Map.fromList $ map (\(GHC.L l n) -> (l,n)) namesIe
|
||||
|
||||
-- If the name does not exist (e.g. a TH Splice that has been expanded, make a new one)
|
||||
-- No attempt is made to make sure that equivalent ones have equivalent names.
|
||||
lookupName l n i = case Map.lookup l nameMap of
|
||||
Just v -> v
|
||||
Nothing -> case n of
|
||||
GHC.Unqual u -> mkNewGhcNamePure 'h' i Nothing (GHC.occNameString u)
|
||||
#if __GLASGOW_HASKELL__ <= 710
|
||||
GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToPackageKey "") q)) (GHC.occNameString u)
|
||||
#else
|
||||
GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToUnitId "") q)) (GHC.occNameString u)
|
||||
#endif
|
||||
_ -> error "initRdrNameMap:should not happen"
|
||||
|
||||
r = Map.fromList $ map (\((l,n),i) -> (l,lookupName l n i)) $ zip rdrNames [1..]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
nameSybQuery :: (SYB.Typeable a, SYB.Typeable t)
|
||||
=> (GHC.Located a -> Maybe r) -> t -> Maybe r
|
||||
nameSybQuery checker = q
|
||||
where
|
||||
q = Nothing `SYB.mkQ` worker
|
||||
#if __GLASGOW_HASKELL__ <= 710
|
||||
`SYB.extQ` workerBind
|
||||
`SYB.extQ` workerExpr
|
||||
`SYB.extQ` workerHsTyVarBndr
|
||||
`SYB.extQ` workerLHsType
|
||||
#endif
|
||||
|
||||
worker (pnt :: (GHC.Located a))
|
||||
= checker pnt
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 710
|
||||
workerBind (GHC.L l (GHC.VarPat name))
|
||||
= checker (GHC.L l name)
|
||||
workerBind _ = Nothing
|
||||
|
||||
workerExpr ((GHC.L l (GHC.HsVar name)))
|
||||
= checker (GHC.L l name)
|
||||
workerExpr _ = Nothing
|
||||
|
||||
-- workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a))
|
||||
-- = checker (GHC.L ln name)
|
||||
-- workerLIE _ = Nothing
|
||||
|
||||
workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name)))
|
||||
= checker (GHC.L l name)
|
||||
workerHsTyVarBndr _ = Nothing
|
||||
|
||||
workerLHsType ((GHC.L l (GHC.HsTyVar name)))
|
||||
= checker (GHC.L l name)
|
||||
workerLHsType _ = Nothing
|
||||
#endif
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
mkNewGhcNamePure :: Char -> Int -> Maybe GHC.Module -> String -> GHC.Name
|
||||
mkNewGhcNamePure c i maybeMod name =
|
||||
let un = GHC.mkUnique c i -- H for HaRe :)
|
||||
n = case maybeMod of
|
||||
Nothing -> GHC.mkInternalName un (GHC.mkVarOcc name) GHC.noSrcSpan
|
||||
Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) GHC.noSrcSpan
|
||||
in n
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
-- |Get all the names in the given syntax element
|
||||
hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName]
|
||||
hsNamessRdr t = nub $ fromMaybe [] r
|
||||
where
|
||||
r = (SYB.everything mappend (inName) t)
|
||||
|
||||
checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName]
|
||||
checker x = Just [x]
|
||||
|
||||
inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName]
|
||||
inName = nameSybQuery checker
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
@ -49,10 +49,11 @@ import Haskell.Ide.Engine.Config
|
||||
import Haskell.Ide.Engine.MonadFunctions
|
||||
import Haskell.Ide.Engine.MonadTypes
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import Haskell.Ide.Engine.Support.FromHaRe
|
||||
import HscTypes
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.VFS as VFS
|
||||
import Language.Haskell.Refact.Utils.MonadFunctions
|
||||
-- import Language.Haskell.Refact.Utils.MonadFunctions
|
||||
import Name
|
||||
import NameCache
|
||||
import Outputable (Outputable)
|
||||
@ -438,3 +439,5 @@ getFormattingPlugin config plugins = do
|
||||
fmtPlugin <- Map.lookup providerName (ipMap plugins)
|
||||
fmtProvider <- pluginFormattingProvider fmtPlugin
|
||||
return (fmtPlugin, fmtProvider)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
@ -48,7 +48,7 @@ import Haskell.Ide.Engine.MonadFunctions
|
||||
import Haskell.Ide.Engine.MonadTypes
|
||||
import qualified Haskell.Ide.Engine.Plugin.ApplyRefact as ApplyRefact
|
||||
import Haskell.Ide.Engine.Plugin.Base
|
||||
import qualified Haskell.Ide.Engine.Plugin.HaRe as HaRe
|
||||
-- import qualified Haskell.Ide.Engine.Plugin.HaRe as HaRe
|
||||
import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import qualified Haskell.Ide.Engine.Scheduler as Scheduler
|
||||
@ -506,13 +506,13 @@ reactor inp diagIn = do
|
||||
|
||||
ReqRename req -> do
|
||||
liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req
|
||||
let (params, doc, pos) = reqParams req
|
||||
newName = params ^. J.newName
|
||||
callback = reactorSend . RspRename . Core.makeResponseMessage req
|
||||
let hreq = GReq tn "HaRe-rename" (Just doc) Nothing (Just $ req ^. J.id) callback mempty
|
||||
$ HaRe.renameCmd' doc pos newName
|
||||
makeRequest hreq
|
||||
|
||||
-- let (params, doc, pos) = reqParams req
|
||||
-- newName = params ^. J.newName
|
||||
-- callback = reactorSend . RspRename . Core.makeResponseMessage req
|
||||
-- let hreq = GReq tn "HaRe-rename" (Just doc) Nothing (Just $ req ^. J.id) callback mempty
|
||||
-- $ HaRe.renameCmd' doc pos newName
|
||||
-- makeRequest hreq
|
||||
reactorSend $ RspRename $ Core.makeResponseMessage req mempty
|
||||
|
||||
-- -------------------------------
|
||||
|
||||
@ -984,7 +984,7 @@ hieOptions commandIds =
|
||||
hieHandlers :: TChan ReactorInput -> Core.Handlers
|
||||
hieHandlers rin
|
||||
= def { Core.initializedHandler = Just $ passHandler rin NotInitialized
|
||||
, Core.renameHandler = Just $ passHandler rin ReqRename
|
||||
-- , Core.renameHandler = Just $ passHandler rin ReqRename
|
||||
, Core.definitionHandler = Just $ passHandler rin ReqDefinition
|
||||
, Core.typeDefinitionHandler = Just $ passHandler rin ReqTypeDefinition
|
||||
, Core.referencesHandler = Just $ passHandler rin ReqFindReferences
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
|
||||
10
stack.yaml
10
stack.yaml
@ -5,11 +5,11 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- ./hie-bios
|
||||
- ./submodules/HaRe
|
||||
# - ./submodules/HaRe
|
||||
- ./submodules/cabal-helper
|
||||
- ./submodules/ghc-mod/ghc-project-types
|
||||
|
||||
- deque-0.4.3@sha256:b988c70a1599b10c7cb643e9c8b0ae4d0166bb2f39c1e13c06a0aeaff29bd9cb,1873
|
||||
- deque-0.4.3
|
||||
- ansi-terminal-0.8.2
|
||||
- bytestring-trie-0.2.5.0
|
||||
- ansi-wl-pprint-0.6.8.2
|
||||
@ -30,9 +30,9 @@ extra-deps:
|
||||
- clock-0.7.2
|
||||
- ghc-exactprint-0.6.2 # for HaRe
|
||||
# - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219
|
||||
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
|
||||
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
|
||||
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
|
||||
- extra-1.6.18
|
||||
- unix-compat-0.5.2
|
||||
- yaml-0.11.1.2
|
||||
|
||||
flags:
|
||||
haskell-ide-engine:
|
||||
|
||||
@ -1 +0,0 @@
|
||||
Subproject commit 33a6fe617acc672d0f19f96cb557ca82651ffa54
|
||||
@ -7,7 +7,7 @@ import Control.Concurrent
|
||||
import Control.Concurrent.STM.TChan
|
||||
import Control.Monad.STM
|
||||
import Data.Aeson
|
||||
import qualified Data.HashMap.Strict as H
|
||||
-- import qualified Data.HashMap.Strict as H
|
||||
import Data.Typeable
|
||||
import qualified Data.Text as T
|
||||
import Data.Default
|
||||
@ -33,7 +33,7 @@ import System.IO
|
||||
import Haskell.Ide.Engine.Plugin.ApplyRefact
|
||||
import Haskell.Ide.Engine.Plugin.Base
|
||||
import Haskell.Ide.Engine.Plugin.Example2
|
||||
import Haskell.Ide.Engine.Plugin.HaRe
|
||||
-- import Haskell.Ide.Engine.Plugin.HaRe
|
||||
import Haskell.Ide.Engine.Plugin.Bios
|
||||
import Haskell.Ide.Engine.Plugin.Generic
|
||||
|
||||
@ -66,7 +66,6 @@ plugins = pluginDescToIdePlugins
|
||||
[applyRefactDescriptor "applyrefact"
|
||||
,example2Descriptor "eg2"
|
||||
,biosDescriptor "bios"
|
||||
,hareDescriptor "hare"
|
||||
,baseDescriptor "base"
|
||||
]
|
||||
|
||||
@ -149,6 +148,7 @@ funcSpec = describe "functional dispatch" $ do
|
||||
unpackRes (r,Right md) = (r, fromDynJSON md)
|
||||
unpackRes r = error $ "unpackRes:" ++ show r
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "defers responses until module is loaded" $ do
|
||||
|
||||
@ -188,6 +188,8 @@ funcSpec = describe "functional dispatch" $ do
|
||||
hr3 <- atomically $ readTChan logChan
|
||||
unpackRes hr3 `shouldBe` ("IReq IdInt 3",Just Cached)
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "instantly responds to deferred requests if cache is available" $ do
|
||||
-- deferred responses should return something now immediately
|
||||
-- as long as the above test ran before
|
||||
@ -241,6 +243,8 @@ funcSpec = describe "functional dispatch" $ do
|
||||
}
|
||||
])
|
||||
|
||||
-- -----------------------------------------------------
|
||||
|
||||
it "returns hints as diagnostics" $ do
|
||||
|
||||
dispatchGhcRequest 5 (Just testUri) "r5" 5 scheduler logChan "applyrefact" "lint" testUri
|
||||
@ -261,18 +265,23 @@ funcSpec = describe "functional dispatch" $ do
|
||||
}
|
||||
)
|
||||
|
||||
let req6 = HP testUri (toPos (8, 1))
|
||||
dispatchGhcRequest 6 (Just testUri) "r6" 6 scheduler logChan "hare" "demote" req6
|
||||
|
||||
-- let req6 = HP testUri (toPos (8, 1))
|
||||
-- dispatchGhcRequest 6 (Just testUri) "r6" 6 scheduler logChan "hare" "demote" req6
|
||||
--
|
||||
-- hr6 <- atomically $ readTChan logChan
|
||||
-- -- show hr6 `shouldBe` "hr6"
|
||||
-- let textEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
|
||||
-- r6uri = testUri
|
||||
-- unpackRes hr6 `shouldBe` ("r6",Just
|
||||
-- (WorkspaceEdit
|
||||
-- (Just $ H.singleton r6uri textEdits)
|
||||
-- Nothing
|
||||
-- ))
|
||||
dispatchGhcRequest 6 (Just testUri) "r6" 6 scheduler logChan "bios" "check" (toJSON testUri)
|
||||
hr6 <- atomically $ readTChan logChan
|
||||
-- show hr6 `shouldBe` "hr6"
|
||||
let textEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
|
||||
r6uri = testUri
|
||||
unpackRes hr6 `shouldBe` ("r6",Just
|
||||
(WorkspaceEdit
|
||||
(Just $ H.singleton r6uri textEdits)
|
||||
Nothing
|
||||
))
|
||||
unpackRes hr6 `shouldBe` ("r6",Nothing :: Maybe Int)
|
||||
|
||||
-- -----------------------------------------------------
|
||||
|
||||
it "instantly responds to failed modules with no cache with the default" $ do
|
||||
|
||||
|
||||
@ -7,8 +7,8 @@ import Control.Applicative.Combinators
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Monad
|
||||
import Data.Aeson
|
||||
import qualified Data.HashMap.Strict as H
|
||||
-- import Data.Aeson
|
||||
-- import qualified Data.HashMap.Strict as H
|
||||
import Data.Maybe
|
||||
import Language.Haskell.LSP.Test
|
||||
import Language.Haskell.LSP.Types
|
||||
@ -91,6 +91,8 @@ spec = do
|
||||
}
|
||||
]
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "FuncTestFail.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 1 11)
|
||||
@ -104,6 +106,8 @@ spec = do
|
||||
-- (Left (sym:_)) <- getDocumentSymbols doc
|
||||
-- liftIO $ sym ^. name `shouldBe` "main"
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
_ <- openDoc "FuncTest.hs" "haskell"
|
||||
|
||||
@ -125,18 +129,18 @@ spec = do
|
||||
}
|
||||
)
|
||||
|
||||
let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)]
|
||||
args = List [Object args']
|
||||
-- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)]
|
||||
-- args = List [Object args']
|
||||
--
|
||||
-- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing)
|
||||
-- liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty)
|
||||
|
||||
executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing)
|
||||
liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty)
|
||||
|
||||
editReq <- message :: Session ApplyWorkspaceEditRequest
|
||||
let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
|
||||
expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
|
||||
liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit
|
||||
Nothing
|
||||
(Just expectedTextDocEdits)
|
||||
-- editReq <- message :: Session ApplyWorkspaceEditRequest
|
||||
-- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
|
||||
-- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
|
||||
-- liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit
|
||||
-- Nothing
|
||||
-- (Just expectedTextDocEdits)
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module DefinitionSpec where
|
||||
|
||||
-- import Control.Applicative.Combinators
|
||||
import Control.Lens
|
||||
import Control.Monad.IO.Class
|
||||
import Language.Haskell.LSP.Test
|
||||
@ -17,6 +18,8 @@ spec = describe "definitions" $ do
|
||||
let expRange = Range (Position 4 0) (Position 4 3)
|
||||
liftIO $ defs `shouldBe` [Location (doc ^. uri) expRange]
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "goto's imported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 2 8)
|
||||
@ -24,6 +27,8 @@ spec = describe "definitions" $ do
|
||||
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
|
||||
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "goto's exported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 0 15)
|
||||
@ -31,6 +36,8 @@ spec = describe "definitions" $ do
|
||||
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
|
||||
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "goto's imported modules that are loaded" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
_ <- openDoc "Bar.hs" "haskell"
|
||||
@ -39,15 +46,23 @@ spec = describe "definitions" $ do
|
||||
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
|
||||
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
it "goto's imported modules that are loaded, and then closed" $
|
||||
runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
otherDoc <- openDoc "Bar.hs" "haskell"
|
||||
closeDoc otherDoc
|
||||
defs <- getDefinitions doc (Position 2 8)
|
||||
_ <- waitForDiagnostics
|
||||
liftIO $ putStrLn "D"
|
||||
liftIO $ do
|
||||
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
|
||||
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
|
||||
liftIO $ putStrLn "E" -- AZ
|
||||
|
||||
noDiagnostics
|
||||
|
||||
|
||||
zeroRange :: Range
|
||||
zeroRange = Range (Position 0 0) (Position 0 0)
|
||||
|
||||
@ -21,6 +21,8 @@ import qualified Language.Haskell.LSP.Types.Capabilities as C
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
|
||||
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "code actions" $ do
|
||||
describe "hlint suggestions" $ do
|
||||
@ -46,7 +48,7 @@ spec = describe "code actions" $ do
|
||||
contents <- getDocumentEdit doc
|
||||
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
|
||||
|
||||
noDiagnostics
|
||||
-- noDiagnostics
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
@ -65,7 +67,9 @@ spec = describe "code actions" $ do
|
||||
contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
|
||||
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
|
||||
|
||||
noDiagnostics
|
||||
-- noDiagnostics
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "runs diagnostics on save" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
let config = def { diagnosticsOnChange = False }
|
||||
@ -92,7 +96,7 @@ spec = describe "code actions" $ do
|
||||
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
|
||||
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
|
||||
|
||||
noDiagnostics
|
||||
-- noDiagnostics
|
||||
|
||||
-- -----------------------------------
|
||||
|
||||
@ -126,6 +130,9 @@ spec = describe "code actions" $ do
|
||||
liftIO $ x `shouldBe` "foo = putStrLn \"world\""
|
||||
|
||||
describe "import suggestions" $ do
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
describe "formats with brittany" $ hsImportSpec "brittany"
|
||||
[ -- Expected output for simple format.
|
||||
[ "import qualified Data.Maybe"
|
||||
@ -576,6 +583,8 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
|
||||
contents <- getDocumentEdit doc
|
||||
liftIO $ T.lines contents `shouldMatchList` e2
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "multiple import-list formats" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionImportList.hs" "haskell"
|
||||
|
||||
@ -592,6 +601,8 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
|
||||
|
||||
liftIO $ Set.fromList (T.lines contents) `shouldBe` Set.fromList e3
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "respects format config, multiple import-list" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionImportList.hs" "haskell"
|
||||
|
||||
@ -742,6 +753,7 @@ hsImportSpec formatter args =
|
||||
++ T.unpack formatter
|
||||
++ ")\", expected 4, got "
|
||||
++ show (length args)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
fromAction :: CAResult -> CodeAction
|
||||
|
||||
@ -1,82 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module HaReSpec where
|
||||
|
||||
import Control.Applicative.Combinators
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Language.Haskell.LSP.Test
|
||||
import Language.Haskell.LSP.Types
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "HaRe" $
|
||||
context "code actions" $ do
|
||||
context "lift one level" $
|
||||
it "works" $
|
||||
let r = Range (Position 2 8) (Position 2 17)
|
||||
expected =
|
||||
"module HaReLift where\n\
|
||||
\foo = bar\n\n\
|
||||
\bar = \"hello\""
|
||||
in execCodeAction "HaReLift.hs" r "Lift bar one level" expected
|
||||
context "lift to top level" $
|
||||
it "works" $
|
||||
let r = Range (Position 2 8) (Position 2 17)
|
||||
expected =
|
||||
"module HaReLift where\n\
|
||||
\foo = bar\n\n\
|
||||
\bar = \"hello\""
|
||||
in execCodeAction "HaReLift.hs" r "Lift bar to top level" expected
|
||||
context "delete definition" $
|
||||
it "works" $
|
||||
let r = Range (Position 1 0) (Position 1 4)
|
||||
expected = "module HaReLift where\n"
|
||||
in execCodeAction "HaReLift.hs" r "Delete definition of foo" expected
|
||||
context "duplicate definition" $
|
||||
it "works" $
|
||||
let r = Range (Position 1 0) (Position 1 4)
|
||||
expected =
|
||||
"module HaReLift where\n\
|
||||
\foo = bar\n\
|
||||
\ where bar = \"hello\"\n\
|
||||
\foo' = bar\n\
|
||||
\ where bar = \"hello\"\n"
|
||||
in execCodeAction "HaReLift.hs" r "Duplicate definition of foo" expected
|
||||
context "demote definition" $ it "works" $
|
||||
let r = Range (Position 5 0) (Position 5 1)
|
||||
expected = "\nmain = putStrLn \"hello\"\n\n\
|
||||
\foo x = y + 3\n where\n y = 7\n"
|
||||
in execCodeAction "HaReDemote.hs" r "Demote y one level" expected
|
||||
-- TODO: Case split does not work
|
||||
-- TOOD: @fendor add github issue link
|
||||
-- context "casesplit argument" $ it "works" $
|
||||
-- let r = Range (Position 4 5) (Position 4 6)
|
||||
-- expected = "\nmain = putStrLn \"hello\"\n\n\
|
||||
-- \foo :: Maybe Int -> ()\n\
|
||||
-- \foo Nothing = ()\n\
|
||||
-- \foo (Just x) = ()\n"
|
||||
-- in execCodeAction "GhcModCaseSplit.hs" r "Case split on x" expected
|
||||
|
||||
|
||||
getCANamed :: T.Text -> [CAResult] -> CodeAction
|
||||
getCANamed named = head . mapMaybe test
|
||||
where test (CACodeAction ca@(CodeAction t _ _ _ _))
|
||||
| named `T.isInfixOf` t = Just ca
|
||||
| otherwise = Nothing
|
||||
test _ = Nothing
|
||||
|
||||
execCodeAction :: String -> Range -> T.Text -> T.Text -> IO ()
|
||||
execCodeAction fp r n expected = runSession hieCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc fp "haskell"
|
||||
|
||||
-- Code actions aren't deferred - need to wait for compilation
|
||||
_ <- count 2 waitForDiagnostics
|
||||
|
||||
ca <- getCANamed n <$> getCodeActions doc r
|
||||
executeCodeAction ca
|
||||
|
||||
content <- getDocumentEdit doc
|
||||
|
||||
liftIO $ content `shouldBe` expected
|
||||
@ -1,316 +0,0 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module HaRePluginSpec where
|
||||
|
||||
import Control.Monad.Trans.Free
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.HashMap.Strict as H
|
||||
import GHC ( getSessionDynFlags )
|
||||
import Haskell.Ide.Engine.Ghc
|
||||
import Haskell.Ide.Engine.PluginApi
|
||||
import Haskell.Ide.Engine.MonadTypes
|
||||
import Haskell.Ide.Engine.PluginUtils
|
||||
import Haskell.Ide.Engine.Plugin.HaRe
|
||||
import Haskell.Ide.Engine.Support.HieExtras
|
||||
import Language.Haskell.LSP.Types ( Location(..)
|
||||
, TextEdit(..)
|
||||
)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import TestUtils
|
||||
import Test.Hspec
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
|
||||
{-# ANN module ("hlint: ignore Redundant do" :: String) #-}
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "hare plugin" hareSpec
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
testPlugins :: IdePlugins
|
||||
testPlugins = pluginDescToIdePlugins [hareDescriptor "hare"]
|
||||
|
||||
dispatchRequestPGoto :: IdeGhcM a -> IO a
|
||||
dispatchRequestPGoto =
|
||||
withCurrentDirectory "./test/testdata/gototest"
|
||||
. runIGM testPlugins
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
runWithContext :: Monoid a => Uri -> IdeGhcM (IdeResult a) -> IdeGhcM (IdeResult a)
|
||||
runWithContext uri act = case uriToFilePath uri of
|
||||
Just fp -> do
|
||||
df <- getSessionDynFlags
|
||||
res <- runActionWithContext df (Just fp) (IdeResultOk mempty) act
|
||||
case res of
|
||||
IdeResultOk a -> return a
|
||||
IdeResultFail err -> error $ "Could not run in context: " ++ show err
|
||||
Nothing -> error $ "uri not valid: " ++ show uri
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
hareSpec :: Spec
|
||||
hareSpec = do
|
||||
describe "hare plugin commands(old plugin api)" $ do
|
||||
cwd <- runIO getCurrentDirectory
|
||||
-- ---------------------------------
|
||||
|
||||
it "renames" $ withCurrentDirectory "test/testdata" $ do
|
||||
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
|
||||
act = runWithContext uri $ renameCmd' uri (toPos (5,1)) "foolong"
|
||||
arg = HPT uri (toPos (5,1)) "foolong"
|
||||
textEdits = List [TextEdit (Range (Position 3 0) (Position 4 13)) "foolong :: Int -> Int\nfoolong x = x + 3"]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "rename" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "returns an error for invalid rename" $ withCurrentDirectory "test/testdata" $ do
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
|
||||
act = runWithContext uri $ renameCmd' uri (toPos (15,1)) "foolong"
|
||||
arg = HPT uri (toPos (15,1)) "foolong"
|
||||
res = IdeResultFail
|
||||
IdeError { ideCode = PluginError
|
||||
, ideMessage = "rename: \"Invalid cursor position!\"", ideInfo = Null}
|
||||
testCommand testPlugins act "hare" "rename" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "demotes" $ withCurrentDirectory "test/testdata" $ do
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReDemote.hs"
|
||||
act = runWithContext uri $ demoteCmd' uri (toPos (6,1))
|
||||
arg = HP uri (toPos (6,1))
|
||||
textEdits = List [TextEdit (Range (Position 4 0) (Position 5 5)) " where\n y = 7"]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "demote" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "duplicates a definition" $ withCurrentDirectory "test/testdata" $ do
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
|
||||
act = runWithContext uri $ dupdefCmd' uri (toPos (5,1)) "foonew"
|
||||
arg = HPT uri (toPos (5,1)) "foonew"
|
||||
textEdits = List [TextEdit (Range (Position 6 0) (Position 6 0)) "foonew :: Int -> Int\nfoonew x = x + 3\n\n"]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "dupdef" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "converts if to case" $ withCurrentDirectory "test/testdata" $ do
|
||||
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReCase.hs"
|
||||
act = runWithContext uri $ iftocaseCmd' uri (Range (toPos (5,9))
|
||||
(toPos (9,12)))
|
||||
arg = HR uri (toPos (5,9)) (toPos (9,12))
|
||||
textEdits = List [TextEdit (Range (Position 4 0) (Position 8 11))
|
||||
"foo x = case odd x of\n True ->\n x + 3\n False ->\n x"]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "iftocase" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "lifts one level" $ withCurrentDirectory "test/testdata" $ do
|
||||
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReMoveDef.hs"
|
||||
act = runWithContext uri $ liftonelevelCmd' uri (toPos (6,5))
|
||||
arg = HP uri (toPos (6,5))
|
||||
textEdits = List [ TextEdit (Range (Position 6 0) (Position 6 0)) "y = 4\n\n"
|
||||
, TextEdit (Range (Position 4 0) (Position 6 0)) ""]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "liftonelevel" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "lifts to top level" $ withCurrentDirectory "test/testdata" $ do
|
||||
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReMoveDef.hs"
|
||||
act = runWithContext uri $ lifttotoplevelCmd' uri (toPos (12,9))
|
||||
arg = HP uri (toPos (12,9))
|
||||
textEdits = List [ TextEdit (Range (Position 13 0) (Position 13 0)) "\n"
|
||||
, TextEdit (Range (Position 12 0) (Position 12 0)) "z = 7\n"
|
||||
, TextEdit (Range (Position 10 0) (Position 12 0)) ""
|
||||
]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "lifttotoplevel" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "deletes a definition" $ withCurrentDirectory "test/testdata" $ do
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/FuncTest.hs"
|
||||
act = runWithContext uri $ deleteDefCmd' uri (toPos (6,1))
|
||||
arg = HP uri (toPos (6,1))
|
||||
textEdits = List [TextEdit (Range (Position 4 0) (Position 7 0)) ""]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "deletedef" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
it "generalises an applicative" $ withCurrentDirectory "test/testdata/HaReGA1/" $ do
|
||||
let uri = filePathToUri $ cwd </> "test/testdata/HaReGA1/HaReGA1.hs"
|
||||
act = runWithContext uri $ genApplicativeCommand' uri (toPos (4,1))
|
||||
arg = HP uri (toPos (4,1))
|
||||
textEdits = List [TextEdit (Range (Position 4 0) (Position 8 12))
|
||||
"parseStr = char '\"' *> (many1 (noneOf \"\\\"\")) <* char '\"'"]
|
||||
res = IdeResultOk $ WorkspaceEdit
|
||||
(Just $ H.singleton uri textEdits)
|
||||
Nothing
|
||||
testCommand testPlugins act "hare" "genapplicative" arg res
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
describe "Additional GHC API commands" $ do
|
||||
cwd <- runIO getCurrentDirectory
|
||||
|
||||
-- TODO: definitions across components does not work currently.
|
||||
-- TODO: @fendor: add github issue link
|
||||
-- it "finds definition across components" $ do
|
||||
-- let fp = cwd </> "test/testdata/gototest/app/Main.hs"
|
||||
-- let u = filePathToUri $ fp
|
||||
-- lreq = runWithContext u $ setTypecheckedModule u
|
||||
-- req = liftToGhc $ TestDeferM $ findDef u (toPos (7,8))
|
||||
-- r <- dispatchRequestPGoto $ lreq >> req
|
||||
-- r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
-- (Range (toPos (6,1)) (toPos (6,9)))]
|
||||
-- let req2 = liftToGhc $ TestDeferM $ findDef u (toPos (7,20))
|
||||
-- r2 <- dispatchRequestPGoto $ lreq >> req2
|
||||
-- r2 `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
|
||||
-- (Range (toPos (5,1)) (toPos (5,2)))]
|
||||
it "finds definition in the same component" $ do
|
||||
let fp = cwd </> "test/testdata/gototest/src/Lib2.hs"
|
||||
let u = filePathToUri $ fp
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findDef u (toPos (6,5))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (6,1)) (toPos (6,9)))]
|
||||
it "finds local definitions" $ do
|
||||
let fp = cwd </> "test/testdata/gototest/src/Lib2.hs"
|
||||
let u = filePathToUri $ fp
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findDef u (toPos (7,11))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
|
||||
(Range (toPos (10,9)) (toPos (10,10)))]
|
||||
let req2 = liftToGhc $ TestDeferM $ findDef u (toPos (10,13))
|
||||
r2 <- dispatchRequestPGoto $ lreq >> req2
|
||||
r2 `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
|
||||
(Range (toPos (9,9)) (toPos (9,10)))]
|
||||
it "finds local definition of record variable" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (11, 23))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (8, 1)) (toPos (8, 29)))
|
||||
]
|
||||
it "finds local definition of newtype variable" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (16, 21))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (13, 1)) (toPos (13, 30)))
|
||||
]
|
||||
it "finds local definition of sum type variable" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (21, 13))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (18, 1)) (toPos (18, 26)))
|
||||
]
|
||||
it "finds local definition of sum type contructor" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (24, 7))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (18, 1)) (toPos (18, 26)))
|
||||
]
|
||||
it "can not find non-local definition of type def" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (30, 17))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk []
|
||||
it "find local definition of type def" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (35, 16))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (18, 1)) (toPos (18, 26)))
|
||||
]
|
||||
it "find type-definition of type def in component" $ do
|
||||
let fp = cwd </> "test/testdata/gototest/src/Lib2.hs"
|
||||
let u = filePathToUri $ fp
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (13, 20))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (8, 1)) (toPos (8, 29)))
|
||||
]
|
||||
it "find definition of parameterized data type" $ do
|
||||
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
|
||||
lreq = runWithContext u $ setTypecheckedModule u
|
||||
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (40, 19))
|
||||
r <- dispatchRequestPGoto $ lreq >> req
|
||||
r `shouldBe` IdeResultOk
|
||||
[ Location
|
||||
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
|
||||
(Range (toPos (37, 1)) (toPos (37, 31)))
|
||||
]
|
||||
|
||||
-- ---------------------------------
|
||||
|
||||
newtype TestDeferM a = TestDeferM (IdeDeferM a) deriving (Functor, Applicative, Monad)
|
||||
instance LiftsToGhc TestDeferM where
|
||||
liftToGhc (TestDeferM (FreeT f)) = do
|
||||
x <- liftToGhc f
|
||||
case x of
|
||||
Pure a -> return a
|
||||
Free (Defer fp cb) -> do
|
||||
fp' <- liftIO $ canonicalizePath fp
|
||||
muc <- fmap (M.lookup fp' . uriCaches) getModuleCache
|
||||
case muc of
|
||||
Just uc -> liftToGhc $ TestDeferM $ cb uc
|
||||
Nothing -> error "No cache to lift IdeDeferM to IdeGhcM"
|
||||
@ -9,8 +9,8 @@ import Haskell.Ide.Engine.MonadTypes
|
||||
|
||||
import Haskell.Ide.Engine.Plugin.ApplyRefact
|
||||
import Haskell.Ide.Engine.Plugin.Generic
|
||||
import Haskell.Ide.Engine.Plugin.HaRe
|
||||
import Haskell.Ide.Engine.Support.HieExtras
|
||||
-- import Haskell.Ide.Engine.Plugin.HaRe
|
||||
-- import Haskell.Ide.Engine.Support.HieExtras
|
||||
import Haskell.Ide.Engine.Config
|
||||
import Language.Haskell.LSP.Types
|
||||
|
||||
@ -39,9 +39,9 @@ jsonSpec = do
|
||||
-- Plugin params
|
||||
prop "ApplyOneParams" (propertyJsonRoundtrip :: ApplyOneParams -> Bool)
|
||||
prop "TypeParams" (propertyJsonRoundtrip :: TypeParams -> Bool)
|
||||
prop "HarePoint" (propertyJsonRoundtrip :: HarePoint -> Bool)
|
||||
prop "HarePointWithText" (propertyJsonRoundtrip :: HarePointWithText -> Bool)
|
||||
prop "HareRange" (propertyJsonRoundtrip :: HareRange -> Bool)
|
||||
-- prop "HarePoint" (propertyJsonRoundtrip :: HarePoint -> Bool)
|
||||
-- prop "HarePointWithText" (propertyJsonRoundtrip :: HarePointWithText -> Bool)
|
||||
-- prop "HareRange" (propertyJsonRoundtrip :: HareRange -> Bool)
|
||||
-- Plugin Api types
|
||||
prop "IdeErrorCode" (propertyJsonRoundtrip :: IdeErrorCode -> Bool)
|
||||
prop "IdeError" (propertyJsonRoundtrip :: IdeError -> Bool)
|
||||
@ -66,14 +66,14 @@ instance Arbitrary ApplyOneParams where
|
||||
instance Arbitrary TypeParams where
|
||||
arbitrary = TP <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary HarePoint where
|
||||
arbitrary = HP <$> arbitrary <*> arbitrary
|
||||
-- instance Arbitrary HarePoint where
|
||||
-- arbitrary = HP <$> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary HarePointWithText where
|
||||
arbitrary = HPT <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
-- instance Arbitrary HarePointWithText where
|
||||
-- arbitrary = HPT <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary HareRange where
|
||||
arbitrary = HR <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
-- instance Arbitrary HareRange where
|
||||
-- arbitrary = HR <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary Uri where
|
||||
arbitrary = filePathToUri <$> arbitrary
|
||||
|
||||
Loading…
Reference in New Issue
Block a user