Merge branch 'master' of github.com:haskell/haskell-language-server

Author: alanz

cabal.project

@@ -10,8 +10,12 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/fendor/hie-bios.git
-    tag: d5b7fc9bb3025b1d4d2ac9c48b588faf18dfce99
+    tag: 89d28817716a1c8df7e191f3a43c4504bc6379eb
 
+source-repository-package
+    type: git
+    location: https://github.com/mpickering/shake
+    tag: 4d56fe9f09bd3bd63ead541c571c756995da490a
 
 tests: true
 documentation: false
@@ -24,4 +28,4 @@ package ghcide
 
 write-ghc-environment-files: never
 
-index-state: 2020-03-24T21:15:10Z
+index-state: 2020-04-24T21:15:10Z

exe/Main.hs

@@ -49,15 +49,15 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
-import Development.Shake                        (Action,  action)
+import Development.Shake                        (Action)
 import DynFlags                                 (gopt_set, gopt_unset,
                                                  updOptLevel)
 import DynFlags                                 (PackageFlag(..), PackageArg(..))
 import GHC hiding                               (def)
 import GHC.Check                                (runTimeVersion, compileTimeVersionFromLibdir)
 -- import GhcMonad
 import HIE.Bios.Cradle
-import HIE.Bios.Environment                     (addCmdOpts)
+import HIE.Bios.Environment                     (addCmdOpts, makeDynFlagsAbsolute)
 import HIE.Bios.Types
 import HscTypes                                 (HscEnv(..), ic_dflags)
 import qualified Language.Haskell.LSP.Core as LSP
@@ -195,7 +195,7 @@ main = do
                     , optInterfaceLoadingDiagnostics = argsTesting
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick)
+            initialise caps (mainRule >> pluginRules plugins)
                 getLspId event hlsLogger debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -218,13 +218,12 @@ main = do
         putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
         putStrLn "\nStep 3/6: Initializing the IDE"
         vfs <- makeVFSHandle
-
         debouncer <- newAsyncDebouncer
         ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSession dir) vfs
 
         putStrLn "\nStep 4/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
-        _ <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
+        _ <- runActionSync "TypecheckTest" ide $ uses TypeCheck (map toNormalizedFilePath' files)
 --        results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "src/Development/IDE/Core/Rules.hs"
 --        results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "exe/Main.hs"
         return ()
@@ -241,11 +240,13 @@ expandFiles = concatMapM $ \x -> do
             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
         return files
 
-
+-- Running this every hover is too expensive, 0.2s on GHC for example
+{-
 kick :: Action ()
 kick = do
     files <- getFilesOfInterest
     void $ uses TypeCheck $ HashSet.toList files
+    -}
 
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()
@@ -525,7 +526,8 @@ memoIO op = do
 setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
 setOptions (ComponentOptions theOpts compRoot _) dflags = do
     cacheDir <- liftIO $ getCacheDir theOpts
-    (dflags', targets) <- addCmdOpts compRoot theOpts dflags
+    (dflags_, targets) <- addCmdOpts theOpts dflags
+    let dflags' = makeDynFlagsAbsolute compRoot dflags_
     let dflags'' =
           -- disabled, generated directly by ghcide instead
           flip gopt_unset Opt_WriteInterface $

ghcide

@@ -49,14 +49,15 @@ library
       Ide.Plugin.Pragmas
       Ide.Plugin.Floskell
       Ide.Plugin.Formatter
+      Ide.PluginUtils
       Ide.Types
       Ide.Version
   other-modules:
       Paths_haskell_language_server
   hs-source-dirs:
       src
   build-depends:
-      base >=4.7 && <5
+      base >=4.12 && <5
     , aeson
     , binary
     , bytestring
@@ -65,6 +66,7 @@ library
     , containers
     , data-default
     , deepseq
+    , Diff
     , directory
     , extra
     , filepath
@@ -77,6 +79,7 @@ library
     , hie-bios >= 0.4
     , hslogger
     , lens
+    , ormolu ^>= 0.0.5.0
     , optparse-simple
     , process
     , regex-tdfa >= 1.3.1.0
@@ -94,9 +97,6 @@ library
     exposed-modules:
       Ide.Plugin.Brittany
 
-  if impl(ghc >= 8.6)
-     build-depends: ormolu >= 0.0.3.1
-
   ghc-options:
          -Wall
          -Wredundant-constraints
@@ -152,7 +152,7 @@ executable haskell-language-server
      -- which works for now.
     , ghc
      --------------------------------------------------------------
-    , ghc-check
+    , ghc-check ^>= 0.1
     , ghc-paths
     , ghcide
     , gitrev

haskell-language-server.cabal

@@ -12,6 +12,7 @@ import           Language.Haskell.Brittany
 import           Language.Haskell.LSP.Types            as J
 import qualified Language.Haskell.LSP.Types.Lens       as J
 import           Ide.Plugin.Formatter
+import           Ide.PluginUtils
 import           Ide.Types
 
 import           System.FilePath
@@ -36,7 +37,7 @@ descriptor plId = PluginDescriptor
 -- If the provider fails an error is returned that can be displayed to the user.
 provider
   :: FormattingProvider IO
-provider _ideState typ contents fp opts = do
+provider _lf _ideState typ contents fp opts = do
 -- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do
   confFile <- liftIO $ getConfFile fp
   let (range, selectedContents) = case typ of
@@ -61,11 +62,6 @@ formatText confFile opts text =
   liftIO $ runBrittany tabSize confFile text
   where tabSize = opts ^. J.tabSize
 
--- | Extend to the line below and above to replace newline character.
-normalize :: Range -> Range
-normalize (Range (Position sl _) (Position el _)) =
-  Range (Position sl 0) (Position (el + 1) 0)
-
 -- | Recursively search in every directory of the given filepath for brittany.yaml.
 -- If no such file has been found, return Nothing.
 getConfFile :: NormalizedFilePath -> IO (Maybe FilePath)

src/Ide/Plugin/Brittany.hs

@@ -125,7 +125,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u
     logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ
     case uriToFilePath' uri of
       Just (toNormalizedFilePath -> filePath) -> do
-        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
+        _ <- runAction "Example.codeLens" ideState $ runMaybeT $ useE TypeCheck filePath
         _diag <- getDiagnostics ideState
         _hDiag <- getHiddenDiagnostics ideState
         let
@@ -190,7 +190,7 @@ logAndRunRequest label getResults ide pos path = do
   logInfo (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
     " in file: " <> T.pack path
-  runAction ide $ getResults filePath pos
+  runAction "Example" ide $ getResults filePath pos
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Example.hs

@@ -125,7 +125,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u
     logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ
     case uriToFilePath' uri of
       Just (toNormalizedFilePath -> filePath) -> do
-        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
+        _ <- runAction (fromNormalizedFilePath filePath) ideState $ runMaybeT $ useE TypeCheck filePath
         _diag <- getDiagnostics ideState
         _hDiag <- getHiddenDiagnostics ideState
         let
@@ -187,7 +187,7 @@ logAndRunRequest label getResults ide pos path = do
   logInfo (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
     " in file: " <> T.pack path
-  runAction ide $ getResults filePath pos
+  runAction "Example2" ide $ getResults filePath pos
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Example2.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -45,7 +44,7 @@ descriptor plId = PluginDescriptor
 -- Formats the given source in either a given Range or the whole Document.
 -- If the provider fails an error is returned that can be displayed to the user.
 provider :: FormattingProvider IO
-provider _ideState typ contents fp _ = do
+provider _lf _ideState typ contents fp _ = do
     let file = fromNormalizedFilePath fp
     config <- findConfigOrDefault file
     let (range, selectedContents) = case typ of

src/Ide/Plugin/Floskell.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -65,20 +64,20 @@ doFormatting lf providers ideState ft uri params = do
       Just provider ->
         case uriToFilePath uri of
           Just (toNormalizedFilePath -> fp) -> do
-            (_, mb_contents) <- runAction ideState $ getFileContents fp
+            (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp
             case mb_contents of
               Just contents -> do
                   logDebug (ideLogger ideState) $ T.pack $
                       "Formatter.doFormatting: contents=" ++ show contents -- AZ
-                  provider ideState ft contents fp params
+                  provider lf ideState ft contents fp params
               Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
           Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
       Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]"
 
 -- ---------------------------------------------------------------------
 
 noneProvider :: FormattingProvider IO
-noneProvider _ _ _ _ _ = return $ Right (List [])
+noneProvider _ _ _ _ _ _ = return $ Right (List [])
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Formatter.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -13,10 +12,6 @@ module Ide.Plugin.Ormolu
 where
 
 import           Control.Exception
-import           Control.Monad
-import           Data.Char
-import           Data.List
-import           Data.Maybe
 import qualified Data.Text as T
 import           Development.IDE.Core.Rules
 import           Development.IDE.Types.Diagnostics as D
@@ -25,7 +20,7 @@ import qualified DynFlags as D
 import qualified EnumSet  as S
 import           GHC
 import           Ide.Types
-import qualified HIE.Bios as BIOS
+import           Ide.PluginUtils
 import           Ide.Plugin.Formatter
 import           Language.Haskell.LSP.Types
 import           Ormolu
@@ -50,19 +45,7 @@ descriptor plId = PluginDescriptor
 -- ---------------------------------------------------------------------
 
 provider :: FormattingProvider IO
-#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
+provider _lf ideState typ contents fp _ = do
   let
     fromDyn :: ParsedModule -> IO [DynOption]
     fromDyn pmod =
@@ -76,62 +59,28 @@ provider ideState typ contents fp _ = do
       in
         return $ map DynOption $ pp <> pm <> ex
 
-  m_parsed <- runAction ideState $ getParsedModule fp
+  m_parsed <- runAction "Ormolu" 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] -> IO (Either OrmoluException T.Text)
-    fmt cont o =
-      try @OrmoluException (ormolu (conf o) (fromNormalizedFilePath fp) $ T.unpack cont)
+    fullRegion = RegionIndices Nothing Nothing
+    rangeRegion s e = RegionIndices (Just s) (Just e)
+    mkConf o region = defaultConfig { cfgDynOptions = o,  cfgRegion = region }
+    fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text)
+    fmt cont conf =
+      try @OrmoluException (ormolu conf (fromNormalizedFilePath fp) $ T.unpack cont)
 
   case typ of
-    FormatText -> ret (fullRange contents) <$> fmt contents cradleOpts
+    FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion)
     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 :: IO (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) -> IO (Either ResponseError (List TextEdit))
-        fmt' (ws, striped) =
-          ret (lineRange r) <$> (fmap (unStrip ws) <$> fmt striped fileOpts)
+        Range (Position sl _) (Position el _) = normalize r
       in
-        maybe err fmt' mStrip
+        ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el))
  where
-  ret :: Range -> Either OrmoluException T.Text -> Either ResponseError (List TextEdit)
-  ret _ (Left err) = Left
+  ret :: 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 $ Right [] -- NOP formatter
-#endif
-
--- ---------------------------------------------------------------------
-
--- | 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
-
--- ---------------------------------------------------------------------
+  ret (Right new) = Right (makeDiffTextEdit contents new)