Merge pull request #1602 from Avi-D-coder/ormolu-range

Ormolu range format support

Author: Avi-D-coder

src/Haskell/Ide/Engine/Plugin/Ormolu.hs

@@ -2,21 +2,31 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 
-module Haskell.Ide.Engine.Plugin.Ormolu ( ormoluDescriptor ) where
+module Haskell.Ide.Engine.Plugin.Ormolu
+  ( ormoluDescriptor
+  )
+where
 
-import Haskell.Ide.Engine.MonadTypes
+import           Haskell.Ide.Engine.MonadTypes
 
 #if __GLASGOW_HASKELL__ >= 806
-import Control.Exception
-import Control.Monad
-import Control.Monad.IO.Class ( liftIO , MonadIO(..) )
-import Data.Aeson ( Value ( Null ) )
-import Data.List
-import Data.Maybe
-import qualified Data.Text as T
-import Ormolu
-import Haskell.Ide.Engine.PluginUtils
-import HIE.Bios.Types
+import           Control.Exception
+import           Control.Monad
+import           Control.Monad.IO.Class         ( liftIO
+                                                , MonadIO(..)
+                                                )
+import           Data.Aeson                     ( Value(Null) )
+import           Data.Char
+import           Data.List
+import           Data.Maybe
+import qualified Data.Text                     as T
+import           GHC
+import           Ormolu
+import           Haskell.Ide.Engine.PluginUtils
+import           Haskell.Ide.Engine.Support.HieExtras
+import           HIE.Bios.Types
+import qualified DynFlags                      as D
+import qualified EnumSet                       as S
 #endif
 
 ormoluDescriptor :: PluginId -> PluginDescriptor
@@ -34,24 +44,71 @@ ormoluDescriptor plId = PluginDescriptor
 
 
 provider :: FormattingProvider
-provider _contents _uri _typ _opts =
 #if __GLASGOW_HASKELL__ >= 806
-  case _typ of
-    FormatRange _ -> return $ IdeResultFail (IdeError PluginError (T.pack "Selection formatting for Ormolu is not currently supported.") Null)
-    FormatText -> pluginGetFile _contents _uri $ \file -> do
-        opts <- lookupComponentOptions file
-        let opts' = map DynOption $ filter exop $ join $ maybeToList $ componentOptions <$> opts
-            conf  = Config opts' False False True False
-        result <- liftIO $ try @OrmoluException (ormolu conf file (T.unpack _contents))
-
-        case result of
-          Left  err -> return $ IdeResultFail (IdeError PluginError (T.pack $ "ormoluCmd: " ++ show err) Null)
-          Right new -> return $ IdeResultOk [TextEdit (fullRange _contents) new]
-  where
-    exop s =
-      "-X" `isPrefixOf` s
-      || "-fplugin=" `isPrefixOf` s
-      || "-pgmF=" `isPrefixOf` s
+provider contents uri typ _ = pluginGetFile contents uri $ \fp -> do
+  opts <- lookupComponentOptions fp
+  let cradleOpts =
+        map DynOption
+          $   filter exop
+          $   join
+          $   maybeToList
+          $   componentOptions
+          <$> opts
+
+      fromDyn tcm _ () =
+        let
+          df = getDynFlags tcm
+          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
+  fileOpts <- ifCachedModuleAndData fp cradleOpts fromDyn
+  let
+    conf o = Config o False False True False
+    fmt :: T.Text -> [DynOption] -> IdeM (Either OrmoluException T.Text)
+    fmt cont o =
+      liftIO $ try @OrmoluException (ormolu (conf o) 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 ws new =
+          fixE $ T.unlines $ map (ws `T.append`) $ fixS $ T.lines new
+        mStrip = case txt of
+          (l : _) ->
+            let ws = fst $ T.span isSpace l
+            in  (,) ws . T.unlines <$> traverse (T.stripPrefix ws) txt
+          _ -> Nothing
+        err = return $ IdeResultFail
+          (IdeError
+            PluginError
+            (T.pack
+              "You must format a whole block of code. Ormolu does not support arbitrary ranges."
+            )
+            Null
+          )
+        fmt' (ws, striped) =
+          ret (lineRange r) <$> (fmap (unStrip ws) <$> fmt striped fileOpts)
+      in
+        maybe err fmt' mStrip
+ where
+  ret _ (Left err) = IdeResultFail
+    (IdeError PluginError (T.pack $ "ormoluCmd: " ++ show err) Null)
+  ret r (Right new) = IdeResultOk [TextEdit r new]
+
+  exop s =
+    "-X" `isPrefixOf` s || "-fplugin=" `isPrefixOf` s || "-pgmF=" `isPrefixOf` s
 #else
-  return $ IdeResultOk [] -- NOP formatter
+provider _ _ _ _ = return $ IdeResultOk [] -- NOP formatter
 #endif