Add fourmolu plugin

.circleci/config.yml

@@ -34,14 +34,6 @@ defaults: &defaults
         name: Stack setup
         command: stack -j 2 --stack-yaml=${STACK_FILE} setup
 
-    - run:
-        name: Install happy
-        command: stack --stack-yaml=${STACK_FILE} install happy
-
-    - run:
-        name: Install Hoogle
-        command: stack -j 1 --stack-yaml=${STACK_FILE} install hoogle
-
     - run:
         name: Build (we need the exe for tests)
         command: stack -j 1 --stack-yaml=${STACK_FILE} install
@@ -50,27 +42,17 @@ defaults: &defaults
 
     - run:
         name: Build Testsuite without running it
-        command: stack -j 2 --stack-yaml=${STACK_FILE}  build --test --no-run-tests
+        command: stack --stack-yaml=${STACK_FILE}  build --test --no-run-tests
         no_output_timeout: 30m
 
     - store_artifacts:
         path: ~/.local/bin
         destination: bin
 
-    - run:
-        name: Generate Hoogle database
-        command: if [ ! -d ~/.hoogle ]; then stack --stack-yaml=${STACK_FILE} exec hoogle generate; fi
-
-    - run:
-        name: Clear cabal-helper cache
-        command: rm -fr ~/.cache/cabal-helper
-
     - save_cache:
         key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
         paths: &cache_paths
           - ~/.stack
-          - ~/.cache
-          - ~/.hoogle
           - ~/build/.stack-work
           - ~/build/ghcide/.stack-work
 
@@ -83,8 +65,11 @@ defaults: &defaults
 
     - run:
         name: Test haskell-language-server
-        # Tests MUST run with -j1, since multiple ghc-mod sessions are not allowed
-        command: stack -j 1 --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs
+        # Tasty by default will run all the tests in parallel. Which should
+        # work ok, but given that these CircleCI runners aren't the beefiest
+        # machine can cause some flakiness. So pass -j1 to Tasty (NOT Stack) to
+        # tell it to go slow and steady.
+        command: stack --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs --test-arguments="-j1"
         no_output_timeout: 120m
 
     - store_test_results:
@@ -93,10 +78,6 @@ defaults: &defaults
     - store_artifacts:
         path: test-logs
 
-    - save_cache:
-        key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}
-        paths: *cache_paths
-
     - save_cache:
         key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }}
         paths: *cache_paths

.github/workflows/build.yml

@@ -90,7 +90,7 @@ jobs:
 
     - uses: actions/upload-artifact@v2
       with:
-        name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.gz
+        name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.${{ steps.compress_server_binary.outputs.extension }}
         path: ${{ steps.compress_server_binary.outputs.path }}
 
     - name: Build Wrapper
@@ -130,6 +130,6 @@ jobs:
     - uses: actions/upload-artifact@v2
       if: matrix.ghc == '8.10.1'
       with:
-        name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.gz
+        name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.${{ steps.compress_wrapper_binary.outputs.extension }}
         path: ${{ steps.compress_wrapper_binary.outputs.path }}
 

cabal.project

@@ -15,3 +15,7 @@ package ghcide
 write-ghc-environment-files: never
 
 index-state: 2020-07-27T12:40:45Z
+
+allow-newer:
+  floskell:aeson
+  stylish-haskell:aeson

exe/Main.hs

@@ -67,6 +67,7 @@ import Ide.Plugin.Example                 as Example
 import Ide.Plugin.Example2                as Example2
 import Ide.Plugin.GhcIde                  as GhcIde
 import Ide.Plugin.Floskell                as Floskell
+import Ide.Plugin.Fourmolu                as Fourmolu
 import Ide.Plugin.Ormolu                  as Ormolu
 import Ide.Plugin.StylishHaskell          as StylishHaskell
 #if AGPL
@@ -101,8 +102,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
       GhcIde.descriptor  "ghcide"
       , Pragmas.descriptor  "pragmas"
       , Floskell.descriptor "floskell"
-      -- , genericDescriptor     "generic"
-      -- , ghcmodDescriptor      "ghcmod"
+      , Fourmolu.descriptor "fourmolu"
+    --   , genericDescriptor     "generic"
+    --   , ghcmodDescriptor      "ghcmod"
       , Ormolu.descriptor   "ormolu"
       , StylishHaskell.descriptor "stylish-haskell"
 #if AGPL

haskell-language-server.cabal

@@ -44,6 +44,7 @@ library
       Ide.Plugin.Eval
       Ide.Plugin.Example
       Ide.Plugin.Example2
+      Ide.Plugin.Fourmolu
       Ide.Plugin.GhcIde
       Ide.Plugin.Ormolu
       Ide.Plugin.Pragmas
@@ -70,7 +71,9 @@ library
     , extra
     , filepath
     , floskell == 0.10.*
+    , fourmolu ^>= 0.1
     , ghc
+    , ghc-boot-th
     , ghcide >= 0.1
     , gitrev
     , hashable
@@ -243,7 +246,6 @@ test-suite func-test
                       , haskell-language-server
                       , haskell-lsp
                       , haskell-lsp-types
-                      , hspec-expectations
                       , lens
                       , lsp-test >= 0.11.0.3
                       , tasty

install.hs

@@ -10,8 +10,8 @@ build-depends:
   , hls-install
 -}
 -- call as:
--- * `cabal v2-run install.hs --project-file install/shake.project <target>`
--- * `stack install.hs <target>`
+--  * `cabal v2-run install.hs --project-file install/shake.project <target>`
+--  * `stack install.hs <target>`
 
 -- TODO: set `shake.project` in cabal-config above, when supported
 -- (see https://github.com/haskell/cabal/issues/6353)

src/Ide/Plugin/Fourmolu.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PackageImports      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Ide.Plugin.Fourmolu
+  (
+    descriptor
+  , provider
+  )
+where
+
+import           Control.Exception
+import qualified Data.Text                         as T
+import           Development.IDE.Core.Rules
+import           Development.IDE.Core.RuleTypes    (GhcSession (GhcSession))
+import           Development.IDE.Core.Shake        (use)
+import           Development.IDE.GHC.Util          (hscEnv)
+import           Development.IDE.Types.Diagnostics as D
+import           Development.IDE.Types.Location
+import qualified DynFlags                          as D
+import qualified EnumSet                           as S
+import           GHC
+import           GHC.LanguageExtensions.Type
+import           GhcPlugins                        (HscEnv (hsc_dflags))
+import           Ide.Plugin.Formatter
+import           Ide.PluginUtils
+import           Ide.Types
+import           Language.Haskell.LSP.Core         (LspFuncs (withIndefiniteProgress),
+                                                    ProgressCancellable (Cancellable))
+import           Language.Haskell.LSP.Types
+import "fourmolu" Ormolu
+import           System.FilePath                   (takeFileName)
+import           Text.Regex.TDFA.Text              ()
+
+-- ---------------------------------------------------------------------
+
+descriptor :: PluginId -> PluginDescriptor
+descriptor plId = (defaultPluginDescriptor plId)
+  { pluginFormattingProvider = Just provider
+  }
+
+-- ---------------------------------------------------------------------
+
+provider :: FormattingProvider IO
+provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do
+  let
+    fromDyn :: DynFlags -> IO [DynOption]
+    fromDyn df =
+      let
+        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 showExtension $ S.toList $ D.extensionFlags df
+      in
+        return $ map DynOption $ pp <> pm <> ex
+
+  ghc <- runAction "Fourmolu" ideState $ use GhcSession fp
+  let df = hsc_dflags . hscEnv <$> ghc
+  fileOpts <- case df of
+          Nothing -> return []
+          Just df -> fromDyn df
+
+  let
+    fullRegion = RegionIndices Nothing Nothing
+    rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1)
+    mkConf o region = do
+      printerOpts <- loadConfigFile True (Just fp') defaultPrinterOpts
+      return $ defaultConfig
+        { cfgDynOptions = o
+        , cfgRegion = region
+        , cfgDebug = True
+        , cfgPrinterOpts = printerOpts
+        }
+    fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text)
+    fmt cont conf =
+      try @OrmoluException (ormolu conf fp' $ T.unpack cont)
+    fp' = fromNormalizedFilePath fp
+
+  case typ of
+    FormatText -> ret <$> (fmt contents =<< mkConf fileOpts fullRegion)
+    FormatRange (Range (Position sl _) (Position el _)) ->
+      ret <$> (fmt contents =<< mkConf fileOpts (rangeRegion sl el))
+ where
+  title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)
+  ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit)
+  ret (Left err) = Left
+    (responseError (T.pack $ "fourmoluCmd: " ++ show err) )
+  ret (Right new) = Right (makeDiffTextEdit contents new)
+
+showExtension :: Extension -> String
+showExtension Cpp   = "-XCPP"
+showExtension other = "-X" ++ show other

src/Ide/Plugin/Ormolu.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PackageImports      #-}
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module Ide.Plugin.Ormolu
   (
@@ -12,19 +12,27 @@ module Ide.Plugin.Ormolu
 where
 
 import           Control.Exception
-import qualified Data.Text as T
+import qualified Data.Text                         as T
 import           Development.IDE.Core.Rules
+import           Development.IDE.Core.RuleTypes    (GhcSession (GhcSession))
+import           Development.IDE.Core.Shake        (use)
+import           Development.IDE.GHC.Util          (hscEnv)
 import           Development.IDE.Types.Diagnostics as D
 import           Development.IDE.Types.Location
-import qualified DynFlags as D
-import qualified EnumSet  as S
+import qualified DynFlags                          as D
+import qualified EnumSet                           as S
 import           GHC
-import           Ide.Types
-import           Ide.PluginUtils
+import           GHC.LanguageExtensions.Type
+import           GhcPlugins                        (HscEnv (hsc_dflags))
 import           Ide.Plugin.Formatter
+import           Ide.PluginUtils
+import           Ide.Types
+import           Language.Haskell.LSP.Core         (LspFuncs (withIndefiniteProgress),
+                                                    ProgressCancellable (Cancellable))
 import           Language.Haskell.LSP.Types
-import           Ormolu
-import           Text.Regex.TDFA.Text()
+import "ormolu"  Ormolu
+import           System.FilePath                   (takeFileName)
+import           Text.Regex.TDFA.Text              ()
 
 -- ---------------------------------------------------------------------
 
@@ -36,42 +44,44 @@ descriptor plId = (defaultPluginDescriptor plId)
 -- ---------------------------------------------------------------------
 
 provider :: FormattingProvider IO
-provider _lf ideState typ contents fp _ = do
+provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do
   let
-    fromDyn :: ParsedModule -> IO [DynOption]
-    fromDyn pmod =
+    fromDyn :: DynFlags -> IO [DynOption]
+    fromDyn df =
       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
+        ex = map showExtension $ S.toList $ D.extensionFlags df
       in
         return $ map DynOption $ pp <> pm <> ex
 
-  m_parsed <- runAction "Ormolu" ideState $ getParsedModule fp
-  fileOpts <- case m_parsed of
+  ghc <- runAction "Ormolu" ideState $ use GhcSession fp
+  let df = hsc_dflags . hscEnv <$> ghc
+  fileOpts <- case df of
           Nothing -> return []
-          Just pm -> fromDyn pm
+          Just df -> fromDyn df
 
   let
     fullRegion = RegionIndices Nothing Nothing
-    rangeRegion s e = RegionIndices (Just s) (Just e)
+    rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1)
     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 <$> fmt contents (mkConf fileOpts fullRegion)
-    FormatRange r ->
-      let
-        Range (Position sl _) (Position el _) = normalize r
-      in
-        ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el))
+    FormatRange (Range (Position sl _) (Position el _)) ->
+      ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el))
  where
+  title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)
   ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit)
   ret (Left err) = Left
     (responseError (T.pack $ "ormoluCmd: " ++ show err) )
   ret (Right new) = Right (makeDiffTextEdit contents new)
+
+showExtension :: Extension -> String
+showExtension Cpp   = "-XCPP"
+showExtension other = "-X" ++ show other

src/Ide/PluginUtils.hs

@@ -67,13 +67,11 @@ diffTextEdit fText f2Text withDeletions = J.List r
                         (J.Position el 0)
 
     diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt
-    -- fm has a range wrt to the changed file, which starts in the current file at l
-    -- So the range has to be shifted to start at l
+    -- fm has a range wrt to the changed file, which starts in the current file at l + 1
+    -- So the range has to be shifted to start at l + 1
       where
-        range = J.Range (J.Position (l' - 1) 0)
-                        (J.Position (l' - 1) 0)
-        l' = max l sl -- Needed to add at the end of the file
-        sl = fst $ lrNumbers fm
+        range = J.Range (J.Position l 0)
+                        (J.Position l 0)
         nt = T.pack $ unlines $ lrContents fm
 
 
@@ -109,4 +107,4 @@ clientSupportsDocumentChanges caps =
         WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps
         mDc
   in
-    fromMaybe False supports
+    fromMaybe False supports

stack-8.10.1.yaml

@@ -13,6 +13,7 @@ extra-deps:
 - cabal-plan-0.7.0.0
 - clock-0.7.2
 - floskell-0.10.3
+- fourmolu-0.1.0.0
 - ghc-exactprint-0.6.3
 - lens-4.19.1
 - lsp-test-0.11.0.3

stack-8.6.4.yaml

@@ -20,6 +20,7 @@ extra-deps:
 # - ghcide-0.1.0
 - extra-1.7.3
 - floskell-0.10.3
+- fourmolu-0.1.0.0
 - fuzzy-0.1.0.0
 - ghc-check-0.5.0.1
 - ghc-exactprint-0.6.2 # for HaRe