From e1aaccc59f9392ae25de77920fadb6a95ff1070c Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 3 Apr 2023 00:09:19 -0700 Subject: [PATCH 1/4] Warn when things are unnecessarily monadic --- src/Hint/Monad.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index 5ab05fabd..dbf47bc53 100644 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -62,6 +62,10 @@ issue978 = do \ print "x" \ if False then main else do \ return () + +foo x y z = return 7 -- Make foo into a pure function +foo x y z = pure 7 -- Make foo into a pure function +foo x y z = negate 7 -} @@ -78,6 +82,7 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import GHC.Data.Bag import qualified GHC.Data.Strict +import Control.Monad ( guard ) import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr @@ -99,8 +104,11 @@ unitFuncs :: [String] unitFuncs = ["when","unless","void"] monadHint :: DeclHint -monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d +monadHint _ _ d = + baseHints <> gratuitousHints where + baseHints = concatMap (f Nothing Nothing) $ childrenBi d + gratuitousHints = concatMap gratuitouslyMonadic $ universeBi d decl = declName d f parentDo parentExpr x = monadExp decl parentDo parentExpr x ++ @@ -109,6 +117,23 @@ monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d isHsDo (L _ HsDo{}) = True isHsDo _ = False +gratuitouslyMonadic :: LHsDecl GhcPs -> [Idea] +gratuitouslyMonadic e@(L _ x) = case x of + ValD _ func@(FunBind _ (L _ n) (MG _ (L _ ms))) -> + let fname = occNameString $ rdrNameOcc n in do + guard $ fname /= "main" + L _ (Match _ _ _ (GRHSs _ xs _)) <- ms + L _ (GRHS _ _ (L _ (HsApp _ (L _ (HsVar _ (L _ myFunc))) _))) <- xs + guard (occNameString (rdrNameOcc myFunc) `elem` ["pure", "return"]) + pure $ rawIdea + Suggestion + "Unnecessarily monadic" + (locA $ getLoc e) + (unsafePrettyPrint e) + (Just $ unwords ["Make", fname, "into a pure function"]) + [] + [] + _ -> [] -- | Call with the name of the declaration, -- the nearest enclosing `do` expression From 9acdb90224766feeb795a0eba2f9384b95a637e8 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 3 Apr 2023 16:55:24 -0700 Subject: [PATCH 2/4] Account for multiple patterns/guards and $ operator --- src/Hint/Monad.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index dbf47bc53..22e1d658b 100644 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -65,6 +65,7 @@ issue978 = do \ foo x y z = return 7 -- Make foo into a pure function foo x y z = pure 7 -- Make foo into a pure function +foo x y z = pure $ x + y -- Make foo into a pure function foo x y z = negate 7 -} @@ -118,13 +119,10 @@ monadHint _ _ d = isHsDo _ = False gratuitouslyMonadic :: LHsDecl GhcPs -> [Idea] -gratuitouslyMonadic e@(L _ x) = case x of - ValD _ func@(FunBind _ (L _ n) (MG _ (L _ ms))) -> - let fname = occNameString $ rdrNameOcc n in do - guard $ fname /= "main" - L _ (Match _ _ _ (GRHSs _ xs _)) <- ms - L _ (GRHS _ _ (L _ (HsApp _ (L _ (HsVar _ (L _ myFunc))) _))) <- xs - guard (occNameString (rdrNameOcc myFunc) `elem` ["pure", "return"]) +gratuitouslyMonadic e@(L _ d) = case d of + ValD _ func@(FunBind _ (L _ n) (MG _ (L _ ms))) -> do + guard $ fname /= "main" -- Account for "main = pure ()" test + guard $ all gratuitouslyMonadicExpr $ allMatchExprs ms pure $ rawIdea Suggestion "Unnecessarily monadic" @@ -133,8 +131,21 @@ gratuitouslyMonadic e@(L _ x) = case x of (Just $ unwords ["Make", fname, "into a pure function"]) [] [] + where + fname = occNameString $ rdrNameOcc n + -- Iterate over all of the patterns of the function, as well as all of the guards + allMatchExprs ms = [expr | L _ (Match _ _ _ (GRHSs _ xs _)) <- ms, L _ (GRHS _ _ expr) <- xs] _ -> [] +-- | Handles both of: +-- pure x +-- pure $ f x +gratuitouslyMonadicExpr :: LHsExpr GhcPs -> Bool +gratuitouslyMonadicExpr x = case simplifyExp x of + L _ (HsApp _ (L _ (HsVar _ (L _ myFunc))) _) -> + occNameString (rdrNameOcc myFunc) `elem` ["pure", "return"] + _ -> False + -- | Call with the name of the declaration, -- the nearest enclosing `do` expression -- the nearest enclosing expression From a7e3833f32edcabd7b4d6ccbf4e88ad0e4aef8bd Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 3 Apr 2023 22:43:35 -0700 Subject: [PATCH 3/4] improve output wording --- src/Hint/Monad.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index 22e1d658b..036be2981 100644 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -63,9 +63,9 @@ issue978 = do \ if False then main else do \ return () -foo x y z = return 7 -- Make foo into a pure function -foo x y z = pure 7 -- Make foo into a pure function -foo x y z = pure $ x + y -- Make foo into a pure function +foo x y z = return 7 -- Demote `foo` to a pure function +foo x y z = pure 7 -- Demote `foo` to a pure function +foo x y z = pure $ x + y -- Demote `foo` to a pure function foo x y z = negate 7 -} @@ -128,7 +128,7 @@ gratuitouslyMonadic e@(L _ d) = case d of "Unnecessarily monadic" (locA $ getLoc e) (unsafePrettyPrint e) - (Just $ unwords ["Make", fname, "into a pure function"]) + (Just $ unwords ["Demote", "`" <> fname <> "`", "to a pure function"]) [] [] where From b0292e77f5bf25bb662c2b7de6bee08b4dbe6d39 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 3 Apr 2023 22:53:31 -0700 Subject: [PATCH 4/4] introduce backquote rendering utility function --- src/Config/Type.hs | 5 +++-- src/Hint/Lambda.hs | 2 +- src/Hint/Monad.hs | 3 ++- src/Util.hs | 9 +++++++-- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Config/Type.hs b/src/Config/Type.hs index baf34d73c..b20fda6fa 100644 --- a/src/Config/Type.hs +++ b/src/Config/Type.hs @@ -25,6 +25,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Deriving.Aeson import System.Console.CmdArgs.Implicit import Data.Aeson hiding (Error) +import Util (backquote) getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore @@ -82,8 +83,8 @@ instance Show Note where show IncreasesLaziness = "increases laziness" show DecreasesLaziness = "decreases laziness" show (RemovesError x) = "removes error " ++ x - show (ValidInstance x y) = "requires a valid `" ++ x ++ "` instance for `" ++ y ++ "`" - show (RequiresExtension x) = "may require `{-# LANGUAGE " ++ x ++ " #-}` adding to the top of the file" + show (ValidInstance x y) = unwords ["requires a valid", backquote x, "instance for", backquote y] + show (RequiresExtension x) = unwords ["may require adding", backquote $ unwords ["{-# LANGUAGE", x, "#-}"], "to the top of the file"] show (Note x) = x diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs index dd429a08c..b95306211 100644 --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -208,7 +208,7 @@ lambdaExp _ o@(L _ (HsPar _ _ (view -> App2 (view -> Var_ "flip") origf@(view -> to = nlHsPar $ noLocA $ SectionR EpAnnNotUsed origf y op = if isSymbolRdrName (unLoc f) then unsafePrettyPrint f - else "`" ++ unsafePrettyPrint f ++ "`" + else backquote $ unsafePrettyPrint f var = if rdrNameStr f == "x" then "y" else "x" r = Replace Expr (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")") diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index 036be2981..64964477f 100644 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -74,6 +74,7 @@ foo x y z = negate 7 module Hint.Monad(monadHint) where import Hint.Type +import Util (backquote) import GHC.Hs hiding (Warning) import GHC.Types.Fixity @@ -128,7 +129,7 @@ gratuitouslyMonadic e@(L _ d) = case d of "Unnecessarily monadic" (locA $ getLoc e) (unsafePrettyPrint e) - (Just $ unwords ["Demote", "`" <> fname <> "`", "to a pure function"]) + (Just $ unwords ["Demote", backquote fname, "to a pure function"]) [] [] where diff --git a/src/Util.hs b/src/Util.hs index 6076b6010..4b17bc48f 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -4,7 +4,8 @@ module Util( forceList, gzip, universeParentBi, exitMessage, exitMessageImpure, - getContentsUTF8, wildcardMatch + getContentsUTF8, wildcardMatch, + backquote ) where import System.Exit @@ -41,6 +42,11 @@ getContentsUTF8 = do hSetEncoding stdin utf8 getContents +--------------------------------------------------------------------- +-- RENDERING + +backquote :: String -> String +backquote s = "`" <> s <> "`" --------------------------------------------------------------------- -- DATA.GENERICS @@ -54,7 +60,6 @@ gzip f x y | toConstr x /= toConstr y = Nothing -- in the same order where op (Box x) (Box y) = f x (unsafeCoerce y) - --------------------------------------------------------------------- -- DATA.GENERICS.UNIPLATE.OPERATIONS