diff --git a/.gitmodules b/.gitmodules index 2b771c7a26..7856aaec36 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,10 @@ -[submodule "ghcide"] - path = ghcide - url = https://github.com/digital-asset/ghcide.git +# To remove a submodule you need to: +# +# Delete the relevant section from the .gitmodules file. +# Stage the .gitmodules changes git add .gitmodules +# Delete the relevant section from .git/config. +# Run git rm --cached path_to_submodule (no trailing slash). +# Run rm -rf .git/modules/path_to_submodule +# Commit git commit -m "Removed submodule " +# Delete the now untracked submodule files +# rm -rf path_to_submodule diff --git a/cabal.project b/cabal.project index a2d16c8187..c08ab4fe68 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ packages: ./ - ghcide + -- ghcide tests: true @@ -11,7 +11,4 @@ package ghcide write-ghc-environment-files: never --- pre-brexit --- A later version (2020-02-01T08:48:32Z) has a problem with a diamond --- dependency for cabal-helper and cabal-plan -index-state: 2020-01-31T21:11:24Z +index-state: 2020-02-04T19:45:47Z diff --git a/exe/Main.hs b/exe/Main.hs index ff8bd98360..aed19bc663 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -8,59 +8,65 @@ module Main(main) where import Arguments -import Data.Maybe -import Data.List.Extra -import System.FilePath import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import Data.Default -import System.Time.Extra +import Data.List.Extra +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as T import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest -import Development.IDE.Core.Service +import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules +import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Util +import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol -import Development.IDE.Types.Location +import Development.IDE.Plugin import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Options +import Development.IDE.Types.Location import Development.IDE.Types.Logger -import Development.IDE.GHC.Util -import Development.IDE.Plugin -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Development.IDE.Types.Options +import Development.Shake (Action, action) +import GHC hiding (def) +import HIE.Bios import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) import Linker -import Development.IDE.LSP.LanguageServer import System.Directory.Extra as IO -import System.IO import System.Exit -import Development.Shake (Action, action) -import qualified Data.Set as Set -import qualified Data.Map.Strict as Map - -import GHC hiding (def) - -import HIE.Bios +import System.FilePath +import System.IO +import System.Time.Extra -- --------------------------------------------------------------------- import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Completions as Completions import Ide.Plugin.Example as Example +import Ide.Plugin.Ormolu as Ormolu -- --------------------------------------------------------------------- +-- The plugins configured for use in this instance of the language +-- server. +-- These can be freely added or removed to tailor the available +-- features of the server. idePlugins :: Bool -> Plugin idePlugins includeExample = Completions.plugin <> CodeAction.plugin <> + Ormolu.plugin <> if includeExample then Example.plugin else mempty +-- --------------------------------------------------------------------- + main :: IO () main = do -- WARNING: If you write to stdout before runLanguageServer @@ -100,7 +106,9 @@ main = do putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir - files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles]) + files <- expandFiles (argFiles ++ ["." | null argFiles]) + -- LSP works with absolute file paths, so try and behave similarly + files <- nubOrd <$> mapM canonicalizePath files putStrLn $ "Found " ++ show (length files) ++ " files" putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup" @@ -123,7 +131,11 @@ main = do let grab file = fromMaybe (head sessions) $ do cradle <- Map.lookup file filesToCradles Map.lookup cradle cradlesToSessions - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs + + let options = + (defaultIdeOptions $ return $ return . grab) + { optShakeProfiling = argsShakeProfiling } + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files @@ -164,7 +176,7 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = showEvent lock e = withLock lock $ print e -cradleToSession :: Cradle -> IO HscEnvEq +cradleToSession :: Cradle a -> IO HscEnvEq cradleToSession cradle = do cradleRes <- getCompilerOptions "" cradle opts <- case cradleRes of diff --git a/ghcide b/ghcide deleted file mode 160000 index 913aa5f9fa..0000000000 --- a/ghcide +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 913aa5f9fa3508dcbe423aea3e0d0effe1b57d1b diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 45932f0e65..4ca1680ff3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -29,6 +29,7 @@ library exposed-modules: Ide.Cradle Ide.Plugin.Example + Ide.Plugin.Ormolu Ide.Version other-modules: Paths_haskell_language_server @@ -50,7 +51,7 @@ library , filepath , fuzzy , ghc - , ghcide + , ghcide >= 0.1 , gitrev , haddock-library , hashable @@ -77,6 +78,9 @@ library , transformers , unordered-containers , utf8-string + if impl(ghc >= 8.6) + build-depends: ormolu >= 0.0.3.1 + ghc-options: -Wall -Wredundant-constraints @@ -121,7 +125,7 @@ executable haskell-language-server , ghcide , gitrev , haskell-lsp - , hie-bios >= 0.3.2 && < 0.4 + , hie-bios >= 0.4 , hslogger , haskell-language-server , optparse-applicative diff --git a/src/Ide/Cradle.hs b/src/Ide/Cradle.hs index 3b1a9d9bd5..a6d615a1a8 100644 --- a/src/Ide/Cradle.hs +++ b/src/Ide/Cradle.hs @@ -7,10 +7,9 @@ module Ide.Cradle where import Control.Exception import Control.Monad.IO.Class -import Data.Char (toLower) import Data.Foldable (toList) import Data.Function ((&)) -import Data.List (isPrefixOf, isInfixOf, sortOn, find) +import Data.List (isPrefixOf, sortOn, find) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map @@ -25,14 +24,17 @@ import Distribution.Helper (Package, projectPackages, pUnits, Unit, unitInfo, uiComponents, ChEntrypoint(..), UnitInfo(..)) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) -import HIE.Bios as BIOS -import HIE.Bios.Types as BIOS +import HIE.Bios as Bios +import qualified HIE.Bios.Cradle as Bios +import HIE.Bios.Types (CradleAction(..)) +import qualified HIE.Bios.Types as Bios import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable) import System.Exit import System.FilePath import System.Log.Logger import System.Process (readCreateProcessWithExitCode, shell) + -- --------------------------------------------------------------------- -- | Find the cradle that the given File belongs to. @@ -45,14 +47,15 @@ import System.Process (readCreateProcessWithExitCode, shell) -- If no "hie.yaml" can be found, the implicit config is used. -- The implicit config uses different heuristics to determine the type -- of the project that may or may not be accurate. -findLocalCradle :: FilePath -> IO Cradle +findLocalCradle :: FilePath -> IO (Cradle CabalHelper) findLocalCradle fp = do - cradleConf <- BIOS.findCradle fp - crdl <- case cradleConf of + cradleConf <- Bios.findCradle fp + crdl <- case cradleConf of Just yaml -> do debugm $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" - BIOS.loadCradle yaml - Nothing -> cabalHelperCradle fp + crdl <- Bios.loadCradle yaml + return $ fmap (const CabalNone) crdl + Nothing -> cabalHelperCradle fp logm $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl return crdl @@ -60,29 +63,33 @@ findLocalCradle fp = do -- This might be used to determine the GHC version to use on the project. -- If it is a stack-cradle, we have to use @"stack path --compiler-exe"@ -- otherwise we may ask `ghc` directly what version it is. -isStackCradle :: Cradle -> Bool -isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None"]) - . BIOS.actionName - . BIOS.cradleOptsProg +isStackCradle :: Cradle CabalHelper -> Bool +isStackCradle crdl = Bios.isStackCradle crdl || cabalHelperStackCradle crdl + where + cabalHelperStackCradle = + (`elem` [Bios.Other Stack, Bios.Other StackNone]) + . Bios.actionName + . Bios.cradleOptsProg + -- | Check if the given cradle is a cabal cradle. -- This might be used to determine the GHC version to use on the project. -- If it is a stack-cradle, we have to use @"stack path --compiler-exe"@ -- otherwise we may ask @ghc@ directly what version it is. -isCabalCradle :: Cradle -> Bool -isCabalCradle = - (`elem` - [ "cabal" - , "Cabal-Helper-Cabal-V1" - , "Cabal-Helper-Cabal-V2" - , "Cabal-Helper-Cabal-V1-Dir" - , "Cabal-Helper-Cabal-V2-Dir" - , "Cabal-Helper-Cabal-V2-None" - , "Cabal-Helper-Cabal-None" - ] - ) - . BIOS.actionName - . BIOS.cradleOptsProg +isCabalCradle :: Cradle CabalHelper -> Bool +isCabalCradle crdl = Bios.isCabalCradle crdl || cabalHelperCabalCradle crdl + where + cabalHelperCabalCradle = + (`elem` [Bios.Other CabalV2, Bios.Other CabalNone]) + . Bios.actionName + . Bios.cradleOptsProg + +data CabalHelper + = Stack + | StackNone + | CabalV2 + | CabalNone + deriving (Show, Eq, Ord) -- | Execute @ghc@ that is based on the given cradle. -- Output must be a single line. If an error is raised, e.g. the command @@ -91,7 +98,7 @@ isCabalCradle = -- -- E.g. for a stack cradle, we use @stack ghc@ and for a cabal cradle -- we are taking the @ghc@ that is on the path. -execProjectGhc :: Cradle -> [String] -> IO (Maybe String) +execProjectGhc :: Cradle CabalHelper -> [String] -> IO (Maybe String) execProjectGhc crdl args = do isStackInstalled <- isJust <$> findExecutable "stack" -- isCabalInstalled <- isJust <$> findExecutable "cabal" @@ -147,7 +154,7 @@ tryCommand cmd = do -- | Get the directory of the libdir based on the project ghc. -getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath) +getProjectGhcLibDir :: Cradle CabalHelper -> IO (Maybe FilePath) getProjectGhcLibDir crdl = execProjectGhc crdl ["--print-libdir"] >>= \case Nothing -> do @@ -444,7 +451,7 @@ the compiler options obtained from Cabal-Helper are relative to the package source directory, which is "\/Repo\/SubRepo". -} -cabalHelperCradle :: FilePath -> IO Cradle +cabalHelperCradle :: FilePath -> IO (Cradle CabalHelper) cabalHelperCradle file = do projM <- findCabalHelperEntryPoint file case projM of @@ -454,7 +461,7 @@ cabalHelperCradle file = do return Cradle { cradleRootDir = cwd , cradleOptsProg = - CradleAction { actionName = "Direct" + CradleAction { actionName = Bios.Direct , runCradle = \_ _ -> return $ CradleSuccess @@ -470,7 +477,7 @@ cabalHelperCradle file = do let root = projectRootDir proj -- Create a suffix for the cradle name. -- Purpose is mainly for easier debugging. - let actionNameSuffix = projectSuffix proj + let actionNameSuffix = projectType proj debugm $ "Cabal-Helper dirs: " ++ show [root, file] let dist_dir = getDefaultDistDir proj env <- mkQueryEnv proj dist_dir @@ -487,9 +494,7 @@ cabalHelperCradle file = do return Cradle { cradleRootDir = root , cradleOptsProg = - CradleAction { actionName = "Cabal-Helper-" - ++ actionNameSuffix - ++ "-None" + CradleAction { actionName = Bios.Other (projectNoneType proj) , runCradle = \_ _ -> return CradleNone } } @@ -504,8 +509,7 @@ cabalHelperCradle file = do return Cradle { cradleRootDir = normalisedPackageLocation , cradleOptsProg = - CradleAction { actionName = - "Cabal-Helper-" ++ actionNameSuffix + CradleAction { actionName = Bios.Other actionNameSuffix , runCradle = \_ fp -> cabalHelperAction (Ex proj) env @@ -754,12 +758,19 @@ projectRootDir ProjLocV2File { plProjectDirV2 } = plProjectDirV2 projectRootDir ProjLocV2Dir { plProjectDirV2 } = plProjectDirV2 projectRootDir ProjLocStackYaml { plStackYaml } = takeDirectory plStackYaml -projectSuffix :: ProjLoc qt -> FilePath -projectSuffix ProjLocV1CabalFile {} = "Cabal-V1" -projectSuffix ProjLocV1Dir {} = "Cabal-V1-Dir" -projectSuffix ProjLocV2File {} = "Cabal-V2" -projectSuffix ProjLocV2Dir {} = "Cabal-V2-Dir" -projectSuffix ProjLocStackYaml {} = "Stack" +projectType :: ProjLoc qt -> CabalHelper +projectType ProjLocV1CabalFile {} = CabalV2 +projectType ProjLocV1Dir {} = CabalV2 +projectType ProjLocV2File {} = CabalV2 +projectType ProjLocV2Dir {} = CabalV2 +projectType ProjLocStackYaml {} = Stack + +projectNoneType :: ProjLoc qt -> CabalHelper +projectNoneType ProjLocV1CabalFile {} = CabalNone +projectNoneType ProjLocV1Dir {} = CabalNone +projectNoneType ProjLocV2File {} = CabalNone +projectNoneType ProjLocV2Dir {} = CabalNone +projectNoneType ProjLocStackYaml {} = StackNone -- ---------------------------------------------------------------------------- -- @@ -870,18 +881,25 @@ relativeTo file sourceDirs = -- | Returns a user facing display name for the cradle type, -- e.g. "Stack project" or "GHC session" -cradleDisplay :: IsString a => BIOS.Cradle -> a +cradleDisplay :: IsString a => Cradle CabalHelper -> a cradleDisplay cradle = fromString result - where - result - | "stack" `isInfixOf` name = "Stack project" - | "cabal-v1" `isInfixOf` name = "Cabal (V1) project" - | "cabal" `isInfixOf` name = "Cabal project" - | "direct" `isInfixOf` name = "GHC session" - | "multi" `isInfixOf` name = "Multi Component project" - | otherwise = "project" - name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle) - + where + result + | Bios.isStackCradle cradle + || name + `elem` [Bios.Other Stack, Bios.Other StackNone] + = "Stack project" + | Bios.isCabalCradle cradle + || name + `elem` [Bios.Other CabalV2, Bios.Other CabalNone] + = "Cabal project" + | Bios.isDirectCradle cradle + = "GHC session" + | Bios.isMultiCradle cradle + = "Multi Component project" + | otherwise + = "project" + name = Bios.actionName (Bios.cradleOptsProg cradle) -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index d65360031e..7e86891155 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -47,8 +47,8 @@ plugin = Plugin exampleRules handlersExample <> codeActionPlugin codeAction <> Plugin mempty handlersCodeLens -hover :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover) -hover = request "Hover" blah Nothing foundHover +hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +hover = request "Hover" blah (Right Nothing) foundHover blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) @@ -105,14 +105,14 @@ codeAction -> TextDocumentIdentifier -> Range -> CodeActionContext - -> IO [CAResult] + -> IO (Either ResponseError [CAResult]) codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO Item" tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) "-- TODO added by Example Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - pure + pure $ Right [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] -- --------------------------------------------------------------------- @@ -128,7 +128,7 @@ codeLens :: LSP.LspFuncs () -> IdeState -> CodeLensParams - -> IO (List CodeLens) + -> IO (Either ResponseError (List CodeLens)) codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do @@ -141,11 +141,11 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} "-- TODO added by Example Plugin via code lens action\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing range = (Range (Position 3 0) (Position 4 0)) - pure $ List + pure $ Right $ List -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing ] - Nothing -> pure $ List [] + Nothing -> pure $ Right $ List [] -- | Execute the "codelens.todo" command. executeAddSignatureCommand @@ -163,20 +163,21 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} -- --------------------------------------------------------------------- -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover +foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) foundHover (mbRange, contents) = - Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange + Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown + $ T.intercalate sectionSeparator contents) mbRange -- | Respond to and log a hover or go-to-definition request request :: T.Text -> (NormalizedFilePath -> Position -> Action (Maybe a)) - -> b - -> (a -> b) + -> Either ResponseError b + -> (a -> Either ResponseError b) -> IdeState -> TextDocumentPositionParams - -> IO b + -> IO (Either ResponseError b) request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs new file mode 100644 index 0000000000..05bda2940c --- /dev/null +++ b/src/Ide/Plugin/Ormolu.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Ormolu + ( + plugin + ) +where + +#if __GLASGOW_HASKELL__ >= 806 +import Control.Exception +#if __GLASGOW_HASKELL__ >= 808 +import Control.Monad.IO.Class ( MonadIO(..) ) +#else +import Control.Monad.IO.Class ( liftIO + , MonadIO(..) + ) +#endif +import Data.Char +import qualified Data.Text as T +import GHC +import Ormolu +import qualified DynFlags as D +import qualified EnumSet as S +import qualified HIE.Bios as BIOS +#endif + +import Control.Monad +import Data.List +import Data.Maybe +import Development.IDE.Core.FileStore +import Development.IDE.Core.Rules +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.Shake hiding ( Diagnostic ) +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- +-- New style plugin + +plugin :: Plugin +plugin = Plugin ormoluRules ormoluHandlers + +ormoluRules :: Rules () +ormoluRules = mempty + +ormoluHandlers :: PartialHandlers +ormoluHandlers = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.documentFormattingHandler + = withResponse RspDocumentFormatting formatting + , LSP.documentRangeFormattingHandler + = withResponse RspDocumentRangeFormatting rangeFormatting + } + +formatting :: LSP.LspFuncs () -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) +formatting _lf ideState (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) + = doFormatting ideState FormatText uri params + +rangeFormatting :: LSP.LspFuncs () -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) +rangeFormatting _lf ideState (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) + = doFormatting ideState (FormatRange range) uri params + +doFormatting :: IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) +doFormatting ideState ft uri params + = case uriToFilePath uri of + Just (toNormalizedFilePath -> fp) -> do + (_, mb_contents) <- runAction ideState $ getFileContents fp + case mb_contents of + Just contents -> provider ideState ft contents fp params + Nothing -> return $ Left $ responseError $ T.pack $ "Ormolu plugin: could not get file contents for " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Ormolu plugin: uriToFilePath failed for: " ++ show uri + +-- --------------------------------------------------------------------- + +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range + + +-- | To format a whole document, the 'FormatText' @FormattingType@ can be used. +-- It is required to pass in the whole Document Text for that to happen, an empty text +-- and file uri, does not suffice. +type FormattingProvider m + = IdeState + -> FormattingType -- ^ How much to format + -> T.Text -- ^ Text to format + -> NormalizedFilePath -- ^ location of the file being formatted + -> FormattingOptions -- ^ Options for the formatter + -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting + +-- --------------------------------------------------------------------- + +extractRange :: Range -> T.Text -> T.Text +extractRange (Range (Position sl _) (Position el _)) s = newS + where focusLines = take (el-sl+1) $ drop sl $ T.lines s + newS = T.unlines focusLines + +-- | Gets the range that covers the entire text +fullRange :: T.Text -> Range +fullRange s = Range startPos endPos + where startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines s + +-- | Find the cradle wide 'ComponentOptions' that apply to a 'FilePath' +lookupBiosComponentOptions :: (Monad m) => NormalizedFilePath -> m (Maybe BIOS.ComponentOptions) +lookupBiosComponentOptions _fp = do + -- gmc <- getModuleCache + -- return $ lookupInCache fp gmc (const Just) (Just . compOpts) Nothing + return Nothing + +-- --------------------------------------------------------------------- + +provider :: forall m. (MonadIO m) => FormattingProvider m +#if __GLASGOW_HASKELL__ >= 806 +provider ideState typ contents fp _ = do + let + exop s = + "-X" `isPrefixOf` s || "-fplugin=" `isPrefixOf` s || "-pgmF=" `isPrefixOf` s + opts <- lookupBiosComponentOptions fp + let cradleOpts = + map DynOption + $ filter exop + $ join + $ maybeToList + $ BIOS.componentOptions + <$> opts + let + fromDyn :: ParsedModule -> m [DynOption] + fromDyn pmod = + let + df = ms_hspp_opts $ pm_mod_summary pmod + pp = + let p = D.sPgm_F $ D.settings df + in if null p then [] else ["-pgmF=" <> p] + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df + ex = map (("-X" <>) . show) $ S.toList $ D.extensionFlags df + in + return $ map DynOption $ pp <> pm <> ex + + m_parsed <- liftIO $ runAction ideState $ getParsedModule fp + fileOpts <- case m_parsed of + Nothing -> return [] + Just pm -> fromDyn pm + + let + conf o = Config o False False True False + fmt :: T.Text -> [DynOption] -> m (Either OrmoluException T.Text) + fmt cont o = + liftIO $ try @OrmoluException (ormolu (conf o) (fromNormalizedFilePath fp) $ T.unpack cont) + + case typ of + FormatText -> ret (fullRange contents) <$> fmt contents cradleOpts + FormatRange r -> + let + txt = T.lines $ extractRange r contents + lineRange (Range (Position sl _) (Position el _)) = + Range (Position sl 0) $ Position el $ T.length $ last txt + hIsSpace (h : _) = T.all isSpace h + hIsSpace _ = True + fixS t = if hIsSpace txt && (not $ hIsSpace t) then "" : t else t + fixE t = if T.all isSpace $ last txt then t else T.init t + unStrip :: T.Text -> T.Text -> T.Text + unStrip ws new = + fixE $ T.unlines $ map (ws `T.append`) $ fixS $ T.lines new + mStrip :: Maybe (T.Text, T.Text) + mStrip = case txt of + (l : _) -> + let ws = fst $ T.span isSpace l + in (,) ws . T.unlines <$> traverse (T.stripPrefix ws) txt + _ -> Nothing + err :: m (Either ResponseError (List TextEdit)) + err = return $ Left $ responseError + $ T.pack "You must format a whole block of code. Ormolu does not support arbitrary ranges." + fmt' :: (T.Text, T.Text) -> m (Either ResponseError (List TextEdit)) + fmt' (ws, striped) = + ret (lineRange r) <$> (fmap (unStrip ws) <$> fmt striped fileOpts) + in + maybe err fmt' mStrip + where + ret :: Range -> Either OrmoluException T.Text -> Either ResponseError (List TextEdit) + ret _ (Left err) = Left + (responseError (T.pack $ "ormoluCmd: " ++ show err) ) + ret r (Right new) = Right (List [TextEdit r new]) + +#else +provider _ _ _ _ = return $ IdeResultOk [] -- NOP formatter +#endif + +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs index c438f5bf23..bf67aadbaa 100644 --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -12,6 +12,7 @@ import Distribution.Text (display) import Options.Applicative.Simple (simpleVersion) import Ide.Cradle (execProjectGhc) import qualified HIE.Bios.Types as Bios +import qualified Ide.Cradle as Bios import qualified Paths_haskell_language_server as Meta import System.Directory import System.Info @@ -34,7 +35,7 @@ hieVersion = hieGhcDisplayVersion :: String hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc -getProjectGhcVersion :: Bios.Cradle -> IO String +getProjectGhcVersion :: Bios.Cradle Bios.CabalHelper -> IO String getProjectGhcVersion crdl = fmap (fromMaybe "No System GHC Found.") diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 82a77e5d68..d06bc8055b 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -2,7 +2,7 @@ resolver: lts-13.19 # GHC 8.6.4 packages: - . -- ./ghcide/ +# - ./ghcide/ extra-deps: - brittany-0.12.1.0 @@ -11,6 +11,7 @@ extra-deps: - cabal-helper-1.0.0.0 - cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 +- ghcide-0.1.0 - extra-1.6.18 - floskell-0.10.2 - fuzzy-0.1.0.0 @@ -22,7 +23,7 @@ extra-deps: - haskell-lsp-0.19.0.0 - haskell-lsp-types-0.19.0.0 - haskell-src-exts-1.21.1 -- hie-bios-0.3.2 +- hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 @@ -35,6 +36,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - rope-utf16-splay-0.3.1.0 +- shake-0.18.5 - syz-0.2.0.0 - temporary-1.2.1.1 - unix-compat-0.5.2 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index d4c07d5d60..d30efdb223 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -2,7 +2,7 @@ resolver: lts-14.22 packages: - . -- ./ghcide/ +# - ./ghcide/ extra-deps: - ansi-terminal-0.10.2 @@ -10,15 +10,18 @@ extra-deps: - cabal-helper-1.0.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 +- ghcide-0.1.0 - fuzzy-0.1.0.0 +- ghc-lib-parser-8.8.2 - haddock-library-1.8.0 - haskell-lsp-0.19.0.0 - haskell-lsp-types-0.19.0.0 -- hie-bios-0.3.2 +- hie-bios-0.4.0 - indexed-profunctors-0.1 - lsp-test-0.10.0.0 - optics-core-0.2 - optparse-applicative-0.15.1.0 +- ormolu-0.0.3.1 - parser-combinators-1.2.1 - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index a29ae71b3e..aabfe54cfb 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -2,7 +2,7 @@ resolver: nightly-2020-01-25 packages: - . -- ./ghcide/ +# - ./ghcide/ extra-deps: # - git: https://github.com/haskell/haddock.git @@ -16,10 +16,11 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.2 - fuzzy-0.1.0.0 +- ghcide-0.1.0 - ghc-lib-parser-ex-8.8.2 - haddock-library-1.8.0 - haskell-src-exts-1.21.1 -- hie-bios-0.3.2 +- hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 diff --git a/stack.yaml b/stack.yaml index d4c07d5d60..604898c3f9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ resolver: lts-14.22 packages: - . -- ./ghcide/ +# - ./ghcide/ extra-deps: - ansi-terminal-0.10.2 @@ -11,14 +11,17 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - fuzzy-0.1.0.0 +- ghcide-0.1.0 +- ghc-lib-parser-8.8.2 - haddock-library-1.8.0 - haskell-lsp-0.19.0.0 - haskell-lsp-types-0.19.0.0 -- hie-bios-0.3.2 +- hie-bios-0.4.0 - indexed-profunctors-0.1 - lsp-test-0.10.0.0 - optics-core-0.2 - optparse-applicative-0.15.1.0 +- ormolu-0.0.3.1 - parser-combinators-1.2.1 - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43