Fix pattern synonym, add tests

Author: berberman

ghcide/src/Development/IDE/Plugin/TypeLenses.hs

@@ -6,6 +6,7 @@ module Development.IDE.Plugin.TypeLenses
   )
 where
 
+import           ConLike                             (ConLike (PatSynCon))
 import           Control.Applicative                 ((<|>))
 import           Control.Monad.IO.Class
 import           Data.Aeson.Types                    (Value (..), toJSON)
@@ -94,29 +95,30 @@ commandHandler _ideState wedit = do
   return $ Right Null
 
 suggestSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range@Range {..}}
+suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = Range {..}}
   | _message
       =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text),
     Just bindings <- mBindings,
     Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_type_env, tcg_rn_decls, tcg_rdr_env}} <- mTmr,
     localScope <- getFuzzyScope bindings _start _end,
     Just group <- tcg_rn_decls,
     Just name <- getFirstIdAtLine (succ $ _line _start) group,
-    Just ty <- (lookupTypeEnv tcg_type_env name >>= safeTyThingType) <|> (find (\(x, _) -> x == name) localScope >>= snd),
+    Just (isPatSyn, ty) <-
+      (lookupTypeEnv tcg_type_env name >>= \x -> (isTyThingPatSyn x,) <$> safeTyThingType x)
+        <|> ((False,) <$> (find (\(x, _) -> x == name) localScope >>= snd)),
     tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty,
-    signature <- T.pack $ printName name <> " :: " <> tyMsg,
+    signature <- T.pack $ (if isPatSyn then "pattern " else "") <> printName name <> " :: " <> tyMsg,
+    startCharacter <- if "local binding" `T.isInfixOf` _message then _character _start else 0,
     startOfLine <- Position (_line _start) startCharacter,
     beforeLine <- Range startOfLine startOfLine,
     title <- if isQuickFix then "add signature: " <> signature else signature,
     action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " =
     [(title, [action])]
   | otherwise = []
-  where
-    startCharacter
-      | "Polymorphic local binding" `T.isPrefixOf` _message =
-        _character _start
-      | otherwise =
-        0
+
+isTyThingPatSyn :: TyThing -> Bool
+isTyThingPatSyn (AConLike (PatSynCon _)) = True
+isTyThingPatSyn _                        = False
 
 getFirstIdAtLine :: Int -> HsGroup GhcRn -> Maybe Name
 getFirstIdAtLine line = something (mkQ Nothing f)

ghcide/test/exe/Main.hs

@@ -3183,6 +3183,8 @@ addSigLensesTests = let
       , sigSession enableWarnings "a `haha` b = a b"        "haha :: (t1 -> t2) -> t1 -> t2"
       , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
       , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a"
+      , sigSession enableWarnings "head = 233" "head :: Integer"
+      , sigSession enableWarnings "a *.* b = a b" "(*.*) :: (t1 -> t2) -> t1 -> t2"
       ]
       | (title, enableWarnings) <-
         [("with warnings enabled", True)

haskell-language-server.cabal

@@ -105,52 +105,52 @@ flag all-formatters
 
 flag class
   description: Enable class plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag haddockComments
   description: Enable haddockComments plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag eval
   description: Enable eval plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag importLens
   description: Enable importLens plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag retrie
   description: Enable retrie plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag tactic
   description: Enable tactic plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag hlint
   description: Enable hlint plugin
-  default:     True
+  default:     False
   manual:      False
 
 flag moduleName
   description: Enable moduleName plugin
-  default:     True
+  default:     False
   manual:      True
 
 flag pragmas
   description: Enable pragmas plugin
-  default:     True
+  default:     False
   manual:      True
 
 flag splice
   description: Enable splice plugin
-  default:     True
+  default:     False
   manual:      False
 
 -- formatters