Add support for external Ormolu

Related to haskell#411

Author: Julien Debon

docs/configuration.md

@@ -75,6 +75,10 @@ Plugins have a generic config to control their behaviour. The schema of such con
     - `haskell.plugin.ghcide-type-lenses.config.mode`, default `always`: Control how type lenses are shown. One of `always`, `exported`, `diagnostics`.
   - `hlint`:
     - `haskell.plugin.hlint.config.flags`, default empty: List of flags used by hlint.
+  - `ormolu`:
+    - `haskell.plugin.ormolu.config.external`, default `false`: Use an external `ormolu` executable rather than the one packaged with HLS.
+  - `fourmolu`:
+    - `haskell.plugin.fourmolu.config.external`, default `false`: Use an external `fourmolu` executable rather than the one packaged with HLS.
 This reference of configuration can be outdated at any time but we can query the `haskell-server-executable` about what configuration is effectively used:
 - `haskell-language-server generate-default-config`: will print the json configuration with all default values. It can be used as template to modify it.
 - `haskell-language-server vscode-extension-schema`: will print a json schema used to setup the haskell vscode extension. But it is useful to see what range of values can an option take and a description about it.

plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal

@@ -38,8 +38,10 @@ library
     , lens
     , lsp
     , mtl
+    , process-extras  >= 0.7.1
     , ormolu          ^>=0.1.2 || ^>= 0.2 || ^>= 0.3 || ^>= 0.5 || ^>= 0.6 || ^>= 0.7
     , text
+    , transformers
 
   default-language: Haskell2010
 
@@ -51,10 +53,15 @@ test-suite tests
   hs-source-dirs:   test
   main-is:          Main.hs
   ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+    ormolu:ormolu
   build-depends:
     , base
+    , aeson
+    , containers
     , filepath
     , hls-ormolu-plugin
+    , hls-plugin-api
     , hls-test-utils     == 2.1.0.0
     , lsp-types
     , text

plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs

@@ -1,112 +1,205 @@
 {-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeOperators     #-}
 module Ide.Plugin.Ormolu
   ( descriptor
   , provider
+  , LogEvent
   )
 where
 
 import           Control.Exception               (Handler (..), IOException,
-                                                  SomeException (..), catches)
+                                                  SomeException (..), catches,
+                                                  handle)
 import           Control.Monad.Except            (ExceptT (ExceptT), runExceptT,
                                                   throwError)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class          (liftIO)
 import           Control.Monad.Trans
+import           Control.Monad.Trans.Except      (ExceptT (..), mapExceptT,
+                                                  runExceptT)
 import           Data.Functor                    ((<&>))
+import           Data.List                       (intercalate)
+import           Data.Maybe                      (catMaybes)
+import           Data.Text                       (Text)
 import qualified Data.Text                       as T
 import           Development.IDE                 hiding (pluginHandlers)
 import           Development.IDE.GHC.Compat      (hsc_dflags, moduleNameString)
 import qualified Development.IDE.GHC.Compat      as D
 import qualified Development.IDE.GHC.Compat.Util as S
 import           GHC.LanguageExtensions.Type
 import           Ide.Plugin.Error                (PluginError (PluginInternalError))
+import           Ide.Plugin.Properties
 import           Ide.PluginUtils
 import           Ide.Types                       hiding (Config)
 import qualified Ide.Types                       as Types
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import           Language.LSP.Server             hiding (defaultConfig)
 import           Ormolu
-import           System.FilePath                 (takeFileName)
+import           System.Exit
+import           System.FilePath
+import           System.Process.Run              (cwd, proc)
+import           System.Process.Text             (readCreateProcessWithExitCode)
+import           Text.Read                       (readMaybe)
 
 -- ---------------------------------------------------------------------
 
-descriptor :: Recorder (WithPriority T.Text) -> PluginId -> PluginDescriptor IdeState
+descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
-  { pluginHandlers = mkFormattingHandlers $ provider recorder
+  { pluginHandlers = mkFormattingHandlers $ provider recorder plId
+        , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties}
   }
 
+properties :: Properties '[ 'PropertyKey "external" 'TBoolean]
+properties =
+    emptyProperties
+        & defineBooleanProperty
+            #external
+            "Call out to an external \"ormolu\" executable, rather than using the bundled library"
+            False
+
 -- ---------------------------------------------------------------------
 
-provider :: Recorder (WithPriority T.Text) -> FormattingHandler IdeState
-provider recorder ideState typ contents fp _ = ExceptT $ withIndefiniteProgress title Cancellable $ runExceptT $ do
-  ghc <- liftIO $ runAction "Ormolu" ideState $ use GhcSession fp
-  let df = hsc_dflags . hscEnv <$> ghc
-  fileOpts <- case df of
-    Nothing -> pure []
-    Just df -> pure $ fromDyn df
-
-  logWith recorder Debug $ "Using ormolu-" <> VERSION_ormolu
-
-  let
-    fullRegion = RegionIndices Nothing Nothing
-    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 SomeException T.Text)
-    fmt cont conf = flip catches handlers $ do
-      let fp' = fromNormalizedFilePath fp
+provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState
+provider recorder plId ideState typ contents fp _ = ExceptT $ withIndefiniteProgress title Cancellable $ runExceptT $ do
+  fileOpts <-
+      maybe [] (fromDyn . hsc_dflags . hscEnv)
+          <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp)
+  useCLI <- liftIO $ runAction "Ormolu" ideState $ usePropertyAction #external plId properties
+
+  if useCLI
+      then mapExceptT liftIO $ ExceptT
+           $ handle @IOException
+          (pure . Left . PluginInternalError . T.pack . show)
+           $ runExceptT $ cliHandler fileOpts
+      else do
+          logWith recorder Debug $ LogCompiledInVersion VERSION_ormolu
+
+          let
+            fmt :: T.Text -> Config RegionIndices -> IO (Either SomeException T.Text)
+            fmt cont conf = flip catches handlers $ do
 #if MIN_VERSION_ormolu(0,5,3)
-      cabalInfo <- getCabalInfoForSourceFile fp' <&> \case
-        CabalNotFound                -> Nothing
-        CabalDidNotMention cabalInfo -> Just cabalInfo
-        CabalFound cabalInfo         -> Just cabalInfo
+              cabalInfo <- getCabalInfoForSourceFile fp' <&> \case
+                CabalNotFound                -> Nothing
+                CabalDidNotMention cabalInfo -> Just cabalInfo
+                CabalFound cabalInfo         -> Just cabalInfo
 #if MIN_VERSION_ormolu(0,7,0)
-      (fixityOverrides, moduleReexports) <- getDotOrmoluForSourceFile fp'
-      let conf' = refineConfig ModuleSource cabalInfo (Just fixityOverrides) (Just moduleReexports) conf
+              (fixityOverrides, moduleReexports) <- getDotOrmoluForSourceFile fp'
+              let conf' = refineConfig ModuleSource cabalInfo (Just fixityOverrides) (Just moduleReexports) conf
 #else
-      fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo
-      let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf
+              fixityOverrides <- traverse getFixityOverridesForSourceFile cabalInfo
+              let conf' = refineConfig ModuleSource cabalInfo fixityOverrides conf
 #endif
-      let cont' = cont
+              let cont' = cont
 #else
-      let conf' = conf
-          cont' = T.unpack cont
+              let conf' = conf
+                  cont' = T.unpack cont
 #endif
-      Right <$> ormolu conf' fp' cont'
-    handlers =
-      [ Handler $ pure . Left . SomeException @OrmoluException
-      , Handler $ pure . Left . SomeException @IOException
-      ]
-
-  case typ of
-    FormatText -> do
-      res <- liftIO $ fmt contents (mkConf fileOpts fullRegion)
-      ret res
-    FormatRange (Range (Position sl _) (Position el _)) -> do
-      res <- liftIO $ fmt contents (mkConf fileOpts (rangeRegion (fromIntegral sl) (fromIntegral el)))
-      ret res
+              Right <$> ormolu conf' fp' cont'
+            handlers =
+              [ Handler $ pure . Left . SomeException @OrmoluException
+              , Handler $ pure . Left . SomeException @IOException
+              ]
+
+          res <- liftIO $ fmt contents defaultConfig { cfgDynOptions = map DynOption fileOpts, cfgRegion = region }
+          ret res
  where
+   fp' = fromNormalizedFilePath fp
+
+   region :: RegionIndices
+   region = case typ of
+       FormatText ->
+           RegionIndices Nothing Nothing
+       FormatRange (Range (Position sl _) (Position el _)) ->
+           RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1)
+
    title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp)
 
    ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null)
    ret (Left err)  = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err
    ret (Right new) = pure $ InL $ makeDiffTextEdit contents new
 
-   fromDyn :: D.DynFlags -> [DynOption]
+   fromDyn :: D.DynFlags -> [String]
    fromDyn df =
      let
        pp =
          let p = D.sPgm_F $ D.settings df
          in  ["-pgmF=" <> p | not (null p)]
        pm = ("-fplugin=" <>) . moduleNameString <$> D.pluginModNames df
        ex = showExtension <$> S.toList (D.extensionFlags df)
-     in
-       DynOption <$> pp <> pm <> ex
+     in pp <> pm <> ex
+
+   cliHandler :: [String] -> ExceptT PluginError IO ([TextEdit] |? Null)
+   cliHandler fileOpts = do
+       CLIVersionInfo{noCabal} <- do -- check Ormolu version so that we know which flags to use
+           (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc "ormolu" ["--version"] ) ""
+           let version = do
+                   guard $ exitCode == ExitSuccess
+                   "ormolu" : v : _ <- pure $ T.words out
+                   traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v
+           case version of
+               Just v -> do
+                   logWith recorder Debug $ LogExternalVersion v
+                   pure CLIVersionInfo
+                       { noCabal = v >= [0, 7]
+                       }
+               Nothing -> do
+                   logWith recorder Debug $ LogExternalVersion []
+                   logWith recorder Warning $ NoVersion out
+                   pure CLIVersionInfo
+                       { noCabal = True
+                       }
+       (exitCode, out, err) <- -- run Ormolu
+           liftIO $ readCreateProcessWithExitCode
+               ( proc "ormolu" $
+                   map ("--ghc-opt" <>) fileOpts
+                       <> mwhen noCabal ["--no-cabal"]
+                       <> catMaybes
+                           [ ("--start-line=" <>) . show <$> regionStartLine region
+                           , ("--end-line=" <>) . show <$> regionEndLine region
+                           ]
+               ){cwd = Just $ takeDirectory fp'}
+               contents
+       case exitCode of
+           ExitSuccess -> do
+               logWith recorder Debug $ StdErr err
+               pure $ InL $ makeDiffTextEdit contents out
+           ExitFailure n -> do
+               logWith recorder Info $ StdErr err
+               throwError $ PluginInternalError $ "Ormolu failed with exit code " <> T.pack (show n)
+
+newtype CLIVersionInfo = CLIVersionInfo
+    { noCabal :: Bool
+    }
+
+data LogEvent
+    = NoVersion Text
+    | ConfigPath FilePath
+    | StdErr Text
+    | LogCompiledInVersion String
+    | LogExternalVersion [Int]
+    deriving (Show)
+
+instance Pretty LogEvent where
+    pretty = \case
+        NoVersion t -> "Couldn't get Ormolu version:" <> line <> indent 2 (pretty t)
+        ConfigPath p -> "Loaded Ormolu config from: " <> pretty (show p)
+        StdErr t -> "Ormolu stderr:" <> line <> indent 2 (pretty t)
+        LogCompiledInVersion v -> "Using compiled in ormolu-" <> pretty v
+        LogExternalVersion v ->
+            "Using external ormolu"
+            <> if null v then "" else "-"
+            <> pretty (intercalate "." $ map show v)
 
 showExtension :: Extension -> String
 showExtension Cpp   = "-XCPP"
 showExtension other = "-X" ++ show other
+
+mwhen :: Monoid a => Bool -> a -> a
+mwhen b x = if b then x else mempty

plugins/hls-ormolu-plugin/test/Main.hs

@@ -4,7 +4,10 @@ module Main
   ( main
   ) where
 
+import           Data.Aeson
+import           Data.Functor
 import qualified Data.Text                   as T
+import           Ide.Plugin.Config
 import qualified Ide.Plugin.Ormolu           as Ormolu
 import           Language.LSP.Protocol.Types
 import           System.FilePath
@@ -13,23 +16,27 @@ import           Test.Hls
 main :: IO ()
 main = defaultTestRunner tests
 
-ormoluPlugin :: PluginTestDescriptor T.Text
+ormoluPlugin :: PluginTestDescriptor Ormolu.LogEvent
 ormoluPlugin = mkPluginTestDescriptor Ormolu.descriptor "ormolu"
 
 tests :: TestTree
-tests = testGroup "ormolu"
-  [ goldenWithOrmolu "formats correctly" "Ormolu" "formatted" $ \doc -> do
-      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
-  , goldenWithOrmolu "formats imports correctly" "Ormolu2" "formatted" $ \doc -> do
-      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
+tests = testGroup "ormolu" $
+    [False, True] <&> \cli ->
+    testGroup (if cli then "cli" else "lib")
+      [ goldenWithOrmolu cli "formats correctly" "Ormolu" "formatted" $ \doc -> do
+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
+      , goldenWithOrmolu cli "formats imports correctly" "Ormolu2" "formatted" $ \doc -> do
+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
 #if MIN_VERSION_ormolu(0,5,3)
-  , goldenWithOrmolu "formats operators correctly" "Ormolu3" "formatted" $ \doc -> do
-      formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
+      , goldenWithOrmolu cli "formats operators correctly" "Ormolu3" "formatted" $ \doc -> do
+          formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing)
 #endif
-  ]
+      ]
 
-goldenWithOrmolu :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
-goldenWithOrmolu title path desc = goldenWithHaskellDocFormatter ormoluPlugin "ormolu" def title testDataDir path desc "hs"
+goldenWithOrmolu :: Bool -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+goldenWithOrmolu cli title path desc = goldenWithHaskellDocFormatter ormoluPlugin "ormolu" def title testDataDir path desc "hs"
+ where
+  conf = def{plcConfig = (\(Object obj) -> obj) $ object ["external" .= cli]}
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"