Reduce usage of partial functions (#4123)

Author: jhrcek

.hlint.yaml

@@ -64,8 +64,6 @@
     - Ide.Types
     - Test.Hls
     - Test.Hls.Command
-    - Wingman.Debug
-    - Wingman.Types
     - AutoTupleSpec
   - name: unsafeInterleaveIO
     within:
@@ -76,7 +74,6 @@
     - Ide.Plugin.Eval.Code
     - Development.IDE.Core.Compile
     - Development.IDE.Types.Shake
-    - Wingman.Judgements.SYB
     - Ide.Plugin.Properties
 
   # Things that are a bit dangerous in the GHC API
@@ -105,17 +102,12 @@
     - Ide.Plugin.CallHierarchy.Internal
     - Ide.Plugin.Eval.Code
     - Ide.Plugin.Eval.Util
-    - Ide.Plugin.Floskell
-    - Ide.Plugin.ModuleName
     - Ide.Plugin.Class.ExactPrint
     - TExpectedActual
     - TRigidType
     - TRigidType2
     - RightToLeftFixities
     - Typeclass
-    - Wingman.Judgements
-    - Wingman.Machinery
-    - Wingman.Tactics
     - CompletionTests #Previously part of GHCIDE Main tests
     - DiagnosticTests #Previously part of GHCIDE Main tests
     - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
@@ -149,9 +141,8 @@
     - Main
     - Development.IDE.Spans.Common
     - Ide.PluginUtils
-    - Wingman.Metaprogramming.Parser
     - Development.Benchmark.Rules
-    - ErrorGivenPartialSignature
+    - TErrorGivenPartialSignature
     - IfaceTests #Previously part of GHCIDE Main tests
     - THTests #Previously part of GHCIDE Main tests
     - WatchedFileTests #Previously part of GHCIDE Main tests
@@ -171,8 +162,6 @@
     - Development.IDE.Plugin.Completions.Logic
     - Development.IDE.Spans.Documentation
     - TErrorGivenPartialSignature
-    - Wingman.CaseSplit
-    - Wingman.Simplify
     - InitializeResponseTests #Previously part of GHCIDE Main tests
     - PositionMappingTests #Previously part of GHCIDE Main tests
 
@@ -185,31 +174,23 @@
     within: []
 
   - name: Data.Foldable.foldr1
-    within:
-    - Wingman.Tactics
+    within: []
 
   - name: Data.Maybe.fromJust
     within:
     - Experiments
     - Main
-    - MultipleImports
     - Progress
-    - Utils
     - Development.IDE.Core.Compile
     - Development.IDE.Core.Rules
     - Development.IDE.Core.Shake
-    - Development.IDE.Plugin.Completions
-    - Development.IDE.Plugin.CodeAction.ExactPrint
-    - Development.IDE.Plugin.CodeAction
     - Development.IDE.Test
     - Development.IDE.Graph.Internal.Profile
     - Development.IDE.Graph.Internal.Rules
-    - Ide.Plugin.Class
     - CodeLensTests #Previously part of GHCIDE Main tests
 
   - name: "Data.Map.!"
-    within:
-    - Wingman.LanguageServer
+    within: []
 
   - name: "Data.IntMap.!"
     within: []
@@ -250,7 +231,6 @@
     - Development.IDE.Graph.Internal.Database
     - Development.IDE.GHC.Util
     - Development.IDE.Plugin.CodeAction.Util
-    - Wingman.Debug
 
 # We really do not want novel usages of restricted functions, and mere
 # Warning is not enough to prevent those consistently; you need a build failure.

ghcide/test/exe/FindDefinitionAndHoverTests.hs

@@ -1,6 +1,4 @@
 
-{-# LANGUAGE MultiWayIf #-}
-
 module FindDefinitionAndHoverTests (tests) where
 
 import           Control.Monad

ghcide/test/exe/WatchedFileTests.hs

@@ -17,7 +17,6 @@ import           Language.LSP.Protocol.Types     hiding
 import           Language.LSP.Test
 import           System.Directory
 import           System.FilePath
--- import Test.QuickCheck.Instances ()
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           TestUtils

hls-test-utils/src/Test/Hls.hs

@@ -65,7 +65,7 @@ import           Control.Concurrent.Async           (async, cancel, wait)
 import           Control.Concurrent.Extra
 import           Control.Exception.Safe
 import           Control.Lens.Extras                (is)
-import           Control.Monad                      (guard, unless, void, when)
+import           Control.Monad                      (guard, unless, void)
 import           Control.Monad.Extra                (forM)
 import           Control.Monad.IO.Class
 import           Data.Aeson                         (Result (Success),

plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs

@@ -1,4 +1,4 @@
-module ErrorGivenPartialSignature where
+module TErrorGivenPartialSignature where
 
 partial :: Int -> Int
 partial x = init x

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs

@@ -85,7 +85,7 @@ asStmts (Property t _ _) =
 myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))
 myExecStmt stmt opts = do
     (temp, purge) <- liftIO newTempFile
-    evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)")
+    evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile " <> show temp <> " (P.show x)")
     modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}
     result <- execStmt stmt opts >>= \case
               ExecComplete (Left err) _ -> pure $ Left $ show err

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs

@@ -122,7 +122,7 @@ commentsToSections isLHS Comments {..} =
                      in case parseMaybe lineGroupP $ NE.toList lcs of
                             Nothing -> mempty
                             Just (mls, rs) ->
-                                ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls)
+                                ( maybe mempty (Map.singleton theRan) mls
                                 , -- orders setup sections in ascending order
                                   if null rs
                                     then mempty

plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs

@@ -8,6 +8,7 @@ module Ide.Plugin.Floskell
 
 import           Control.Monad.Except        (throwError)
 import           Control.Monad.IO.Class
+import           Data.List                   (find)
 import qualified Data.Text                   as T
 import qualified Data.Text.Lazy              as TL
 import           Development.IDE             hiding (pluginHandlers)
@@ -53,7 +54,8 @@ findConfigOrDefault file = do
   case mbConf of
     Just confFile -> readAppConfig confFile
     Nothing ->
-      let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles)
-      in pure $ defaultAppConfig { appStyle = gibiansky }
+      pure $ case find (\s -> styleName s == "gibiansky") styles of
+        Just gibiansky -> defaultAppConfig { appStyle = gibiansky }
+        Nothing        -> defaultAppConfig
 
 -- ---------------------------------------------------------------------

plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs

@@ -25,7 +25,7 @@ import           Control.Monad.Trans.Maybe
 import           Data.Aeson                           (toJSON)
 import           Data.Char                            (isLower, isUpper)
 import           Data.List                            (intercalate, minimumBy,
-                                                       stripPrefix, uncons)
+                                                       stripPrefix)
 import qualified Data.List.NonEmpty                   as NE
 import qualified Data.Map                             as Map
 import           Data.Maybe                           (mapMaybe)
@@ -138,7 +138,7 @@ action recorder state uri = do
 -- directories are nested inside each other.
 pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text]
 pathModuleNames recorder state normFilePath filePath
-  | isLower . head $ takeFileName filePath = return ["Main"]
+  | firstLetter isLower $ takeFileName filePath = return ["Main"]
   | otherwise = do
       (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath
       srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
@@ -156,12 +156,16 @@ pathModuleNames recorder state normFilePath filePath
       let suffixes = mapMaybe (`stripPrefix` mdlPath) paths
       pure (map moduleNameFrom suffixes)
   where
+    firstLetter :: (Char -> Bool) -> FilePath -> Bool
+    firstLetter _ []       = False
+    firstLetter pred (c:_) = pred c
+
     moduleNameFrom =
       T.pack
         . intercalate "."
         -- Do not suggest names whose components start from a lower-case char,
         -- they are guaranteed to be malformed.
-        . filter (maybe False (isUpper . fst) . uncons)
+        . filter (firstLetter isUpper)
         . splitDirectories
         . dropExtension
 

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -75,7 +75,6 @@ import           GHC                                               (AddEpAnn (Ad
                                                                     EpAnn (..),
                                                                     EpaLocation (..),
                                                                     LEpaComment)
-import           GHC.Exts                                          (fromList)
 import qualified GHC.LanguageExtensions                            as Lang
 import           Ide.Logger                                        hiding
                                                                    (group)
@@ -189,18 +188,18 @@ extendImportHandler :: CommandFunction IdeState ExtendImport
 extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do
   res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit
   whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do
-    let (_, head -> TextEdit {_range}) = fromJust $ _changes >>= listToMaybe . M.toList
-        srcSpan = rangeToSrcSpan nfp _range
-    LSP.sendNotification SMethod_WindowShowMessage $
-      ShowMessageParams MessageType_Info $
-        "Import "
-          <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent
-          <> "’ from "
-          <> importName
-          <> " (at "
-          <> printOutputable srcSpan
-          <> ")"
-    void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
+    whenJust (listToMaybe =<< listToMaybe . M.elems =<< _changes) $ \TextEdit {_range} -> do
+      let srcSpan = rangeToSrcSpan nfp _range
+      LSP.sendNotification SMethod_WindowShowMessage $
+        ShowMessageParams MessageType_Info $
+          "Import "
+            <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent
+            <> "’ from "
+            <> importName
+            <> " (at "
+            <> printOutputable srcSpan
+            <> ")"
+      void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
   return $ Right $ InR Null
 
 extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit)
@@ -223,8 +222,7 @@ extendImportHandler' ideState ExtendImport {..}
       case existingImport of
         Just imp -> do
             fmap (nfp,) $ liftEither $
-              rewriteToWEdit df doc
-                $
+              rewriteToWEdit df doc $
                   extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp)
 
         Nothing -> do
@@ -235,7 +233,7 @@ extendImportHandler' ideState ExtendImport {..}
                   Nothing -> newThing
                   Just p  -> p <> "(" <> newThing <> ")"
             t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents)
-            return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc, [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})
+            return (nfp, WorkspaceEdit {_changes=Just (M.singleton doc [t]), _documentChanges=Nothing, _changeAnnotations=Nothing})
   | otherwise =
     mzero
 
@@ -609,7 +607,7 @@ suggestDeleteUnusedBinding
         let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames
         in case maybeIdx of
             Nothing -> Nothing
-            Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True)
+            Just _ | [lname] <- lnames -> Just (getLoc $ reLoc lname, True)
             Just idx ->
               let targetLname = getLoc $ reLoc $ lnames !! idx
                   startLoc = srcSpanStart targetLname
@@ -1052,7 +1050,7 @@ suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..}
         parensed =
             "(" `T.isPrefixOf` T.strip (textInRange _range txt)
         -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3]
-        removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort
+        removeAllDuplicates = map NE.head . filter ((==1) . length) . NE.group . sort
         hasDuplicate xs = length xs /= length (S.fromList xs)
         suggestions symbol mods local
           | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of
@@ -1290,7 +1288,7 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _rang
   | otherwise = []
 
 findTypeSignatureName :: T.Text -> Maybe T.Text
-findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head
+findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " >>= listToMaybe
 
 -- | Suggests a constraint for a type signature with any number of existing constraints.
 suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]
@@ -1378,7 +1376,8 @@ removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagno
         & take 2
         & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip)
         & listToMaybe
-        <&> (head >>> parseConstraints)
+        >>= listToMaybe
+        <&> parseConstraints
 
       formatConstraints :: [T.Text] -> T.Text
       formatConstraints [] = ""
@@ -1658,7 +1657,7 @@ findPositionAfterModuleName ps hsmodName' = do
 #endif
         EpAnn _ annsModule _ -> do
             -- Find the first 'where'
-            whereLocation <- fmap NE.head .  NE.nonEmpty . mapMaybe filterWhere .  am_main $ annsModule
+            whereLocation <- listToMaybe . mapMaybe filterWhere $ am_main annsModule
             epaLocationToLine whereLocation
         EpAnnNotUsed -> Nothing
     filterWhere (AddEpAnn AnnWhere loc) = Just loc