[wip] add pragma after she-bang

Author: Ishmum Jawad Khan

plugins/default/src/Ide/Plugin/Pragmas.hs

@@ -11,8 +11,11 @@ module Ide.Plugin.Pragmas
   ) where
 
 import           Control.Lens                    hiding (List)
+import           Control.Applicative             ((<|>))
 import qualified Data.HashMap.Strict             as H
 import qualified Data.Text                       as T
+import           Data.Maybe                      (listToMaybe, fromMaybe)
+import           Data.List                      (findIndex)
 import           Development.IDE                 as D
 import           Ide.Types
 import           Language.Haskell.LSP.Types
@@ -40,16 +43,17 @@ descriptor plId = (defaultPluginDescriptor plId)
 -- Pragma is added to the first line of the Uri.
 -- It is assumed that the pragma name is a valid pragma,
 -- thus, not validated.
-mkPragmaEdit :: Uri -> T.Text -> WorkspaceEdit
-mkPragmaEdit uri pragmaName = res where
+mkPragmaEdit :: Uri -> T.Text -> Maybe ParsedModule -> Maybe WorkspaceEdit
+mkPragmaEdit uri pragmaName mpm = res mpm where
     pos = J.Position 0 0
-    textEdits = J.List
-      [J.TextEdit (J.Range pos pos)
+    textEdits pm = J.List
+      [J.TextEdit (endOfModuleHeader pm Nothing)
                   ("{-# LANGUAGE " <> pragmaName <> " #-}\n")
       ]
-    res = J.WorkspaceEdit
-      (Just $ H.singleton uri textEdits)
+    res (Just pm) = Just $ J.WorkspaceEdit
+      (Just . H.singleton uri $ textEdits pm)
       Nothing
+    res Nothing = Nothing
 
 -- ---------------------------------------------------------------------
 -- | Offer to add a missing Language Pragma to the top of a file.
@@ -61,14 +65,14 @@ codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _mo
     let dflags = ms_hspp_opts . pm_mod_summary <$> pm
         -- Get all potential Pragmas for all diagnostics.
         pragmas = nubOrd $ concatMap (\d -> genPragma dflags (d ^. J.message)) diags
-    cmds <- mapM mkCodeAction pragmas
+    cmds <- mapM (mkCodeAction pm) pragmas
     return $ Right $ List cmds
       where
-        mkCodeAction pragmaName = do
+        mkCodeAction pm pragmaName = do
           let
-            codeAction = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) (Just edit) Nothing
+            codeAction = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) (Just =<< edit) Nothing
             title = "Add \"" <> pragmaName <> "\""
-            edit = mkPragmaEdit (docId ^. J.uri) pragmaName
+            edit = mkPragmaEdit (docId ^. J.uri) pragmaName pm
           return codeAction
 
         genPragma mDynflags target =
@@ -164,3 +168,17 @@ completion lspFuncs _ide complParams = do
                         _xdata = Nothing
                       }
         _ -> return $ Completions $ List []
+
+-- | Find the first non-blank line before the first of (module name / imports / declarations).
+-- Useful for inserting pragmas.
+endOfModuleHeader :: ParsedModule -> Maybe T.Text -> Range
+endOfModuleHeader pm contents =
+    let mod = unLoc $ pm_parsed_source pm
+        modNameLoc = getLoc <$> hsmodName mod
+        firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod)
+        firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod)
+        line = fromMaybe 0 $ firstNonBlankBefore . _line . _start =<< srcSpanToRange =<<
+            modNameLoc <|> firstImportLoc <|> firstDeclLoc
+        firstNonBlankBefore n = (n -) . fromMaybe 0 . findIndex (not . T.null) . reverse . take n . T.lines <$> contents
+        loc = Position line 0
+     in Range loc loc

test/functional/FunctionalCodeAction.hs

@@ -547,6 +547,31 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
                     , "f Record{a, b} = a"
                     ]
 
+            liftIO $ T.lines contents @?= expected
+    , testCase "After Shebang" $ do
+        runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do
+            doc <- openDoc "AfterShebang.hs" "haskell"
+
+            _ <- waitForDiagnosticsFrom doc
+            cas <- map fromAction <$> getAllCodeActions doc
+
+            liftIO $ "Add \"TypeApplications\"" `elem` map (^. L.title) cas @? "Contains TypeApplications code action"
+
+            executeCodeAction $ head cas
+
+            contents <- documentContents doc
+
+            let expected =
+                    [ "#! /usr/bin/env nix-shell"
+                    , "#! nix-shell --pure -i runghc -p \"haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])\""
+                    , "{-# LANGUAGE TypeApplications #-}"
+                    , "{-# LANGUAGE ScopedTypeVariables #-}"
+                    , "module TypeApplications where"
+                    , ""
+                    , "foo :: forall a. a -> a"
+                    , "foo = id @a"
+                    ]
+
             liftIO $ T.lines contents @?= expected
     ]
 

test/testdata/addPragmas/AfterShebang.hs

@@ -0,0 +1,8 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+
+{-# LANGUAGE ScopedTypeVariables #-}
+module AfterShebang where
+
+foo :: forall a. a -> a
+foo = id @a