From dcce7691a87467442df54342289c5544928807e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gohla?= Date: Wed, 10 Jul 2024 18:23:27 +0100 Subject: [PATCH 1/5] Add a hint to avoid capitalisms in identifiers, with some exceptions. --- hints.md | 32 +++++++++++ hlint.cabal | 1 + src/Hint/All.hs | 44 ++++++++------- src/Hint/NoCapitalisms.hs | 113 ++++++++++++++++++++++++++++++++++++++ src/Idea.hs | 6 +- 5 files changed, 174 insertions(+), 22 deletions(-) create mode 100644 src/Hint/NoCapitalisms.hs diff --git a/hints.md b/hints.md index 09be1475b..04c5a991d 100644 --- a/hints.md +++ b/hints.md @@ -1176,6 +1176,38 @@ Does not support refactoring. +## Builtin NoCapitalisms + + + + + + + + + + + + +
Hint NameHintSeverity
Avoid capitalisms +Example: + +type WarpTLSException = () + +
+Found: + +type WarpTLSException = () + +
+Suggestion: + + + +
+Does not support refactoring. +		Suggestion
+ ## Builtin NumLiteral diff --git a/hlint.cabal b/hlint.cabal index c3c8e2d45..cbc787758 100644 --- a/hlint.cabal +++ b/hlint.cabal @@ -168,6 +168,7 @@ library Hint.Type Hint.Unsafe Hint.NumLiteral + Hint.NoCapitalisms Test.All Test.Annotations Test.InputOutput diff --git a/src/Hint/All.hs b/src/Hint/All.hs index 41665c8ef..0af411286 100644 --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -34,6 +34,7 @@ import Hint.Unsafe import Hint.NewType import Hint.Smell import Hint.NumLiteral +import Hint.NoCapitalisms -- | A list of the builtin hints wired into HLint. -- This list is likely to grow over time. @@ -41,7 +42,7 @@ data HintBuiltin = HintList | HintListRec | HintMonad | HintLambda | HintFixities | HintNegation | HintBracket | HintNaming | HintPattern | HintImport | HintExport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict | - HintComment | HintNewType | HintSmell | HintNumLiteral + HintComment | HintNewType | HintSmell | HintNumLiteral | HintNoCapitalisms deriving (Show,Eq,Ord,Bounded,Enum) -- See https://github.com/ndmitchell/hlint/issues/1150 - Duplicate is too slow @@ -50,26 +51,27 @@ issue1150 = True builtin :: HintBuiltin -> Hint builtin x = case x of - HintLambda -> decl lambdaHint - HintImport -> modu importHint - HintExport -> modu exportHint - HintComment -> modu commentHint - HintPragma -> modu pragmaHint - HintDuplicate -> if issue1150 then mempty else mods duplicateHint - HintRestrict -> mempty{hintModule=restrictHint} - HintList -> decl listHint - HintNewType -> decl newtypeHint - HintUnsafe -> decl unsafeHint - HintListRec -> decl listRecHint - HintNaming -> decl namingHint - HintBracket -> decl bracketHint - HintFixities -> mempty{hintDecl=fixitiesHint} - HintNegation -> decl negationParensHint - HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint} - HintPattern -> decl patternHint - HintMonad -> decl monadHint - HintExtensions -> modu extensionsHint - HintNumLiteral -> decl numLiteralHint + HintLambda -> decl lambdaHint + HintImport -> modu importHint + HintExport -> modu exportHint + HintComment -> modu commentHint + HintPragma -> modu pragmaHint + HintDuplicate -> if issue1150 then mempty else mods duplicateHint + HintRestrict -> mempty{hintModule=restrictHint} + HintList -> decl listHint + HintNewType -> decl newtypeHint + HintUnsafe -> decl unsafeHint + HintListRec -> decl listRecHint + HintNaming -> decl namingHint + HintBracket -> decl bracketHint + HintFixities -> mempty{hintDecl=fixitiesHint} + HintNegation -> decl negationParensHint + HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint} + HintPattern -> decl patternHint + HintMonad -> decl monadHint + HintExtensions -> modu extensionsHint + HintNumLiteral -> decl numLiteralHint + HintNoCapitalisms -> decl noCapitalismsHint where wrap = timed "Hint" (drop 4 $ show x) . forceList decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c} diff --git a/src/Hint/NoCapitalisms.hs b/src/Hint/NoCapitalisms.hs new file mode 100644 index 000000000..573b1a443 --- /dev/null +++ b/src/Hint/NoCapitalisms.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{- + Detect uses of capitalisms + + Only allow up to two consecutive capital letters in identifiers. + + Identifiers containing underscores are exempted from thus rule. + Identifiers of FFI bindings are exempted from thus rule. + + +module SSL.Foo -- ??? +data LHsDecl +class FOO a where -- ??? +class Foo a where getFOO -- ??? +data Foo = Bar | BAAZ -- ??? +data Foo = B_ar | BAAZ -- ??? +data Foo = Bar | B_AAZ +data OTPToken = OTPToken -- ??? +data OTP_Token = Foo +sendSMS = ... -- ??? +runTLS = ... -- ??? +runTLSSocket = ... -- ??? +runTLS_Socket +newtype TLSSettings = ... -- ??? +tlsSettings +data CertSettings = CertSettings +tlsServerHooks +tlsServerDHEParams = ... -- ??? +type WarpTLSException = () -- ??? +get_SMS +runCI +foreign import ccall _FIREMISSLES :: IO () +let getSMS = x in foo --- ??? + +-} + + +module Hint.NoCapitalisms(noCapitalismsHint) where + +import Hint.Type (DeclHint,remark, Severity (Ignore)) +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (toList) +import Data.Char +import Data.Maybe + +import GHC.Types.Basic +import GHC.Types.SourceText +import GHC.Data.FastString +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs +import GHC.Types.SrcLoc + +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls +import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +import GHC.Util + +noCapitalismsHint :: DeclHint +noCapitalismsHint _ _ decl = [ remark Ignore "Avoid capitalisms" (reLoc (shorten decl)) + | not $ isForD decl + , name <- nubOrd $ getNames decl + , not $ hasUnderscore name + , hasCapitalism name + ] + +hasUnderscore :: String -> Bool +hasUnderscore = elem '_' + +hasCapitalism :: String -> Bool +hasCapitalism s = any isAllUpper (trigrams s) + where + isAllUpper = all isUpper + trigrams = \case + a:b:c:as -> [a,b,c] : trigrams (c:as) + _otherwise -> [] + +--- these are copied from Hint.Naming --- + +shorten :: LHsDecl GhcPs -> LHsDecl GhcPs +shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = + L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _)))) = + L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) +shorten x = x + +shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) +shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = + L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} + +shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) +shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = + L locGRHS (GRHS ttg0 guards (L locExpr dots)) + where + dots :: HsExpr GhcPs + dots = HsLit EpAnnNotUsed (HsString (SourceText (fsLit "...")) (fsLit "...")) + +getNames :: LHsDecl GhcPs -> [String] +getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) + +getConstructorNames :: HsDecl GhcPs -> [String] +getConstructorNames tycld = case tycld of + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con] + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons + _ -> [] + where + conNames :: [LConDecl GhcPs] -> [String] + conNames = concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) + + conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] + conNamesInDecl ConDeclH98 {con_name = name} = [name] + conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names + diff --git a/src/Idea.hs b/src/Idea.hs index 896e7e5af..1a0992905 100644 --- a/src/Idea.hs +++ b/src/Idea.hs @@ -3,7 +3,7 @@ module Idea( Idea(..), - rawIdea, idea, suggest, suggestRemove, ideaRemove, warn, ignore, + rawIdea, idea, suggest, suggestRemove, ideaRemove, warn, ignore, remark, rawIdeaN, suggestN, ignoreNoSuggestion, showIdeasJson, showIdeaANSI, ideaFile, @@ -107,6 +107,10 @@ idea severity hint from to = ideaRemove :: Severity -> String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea ideaRemove severity hint span from = rawIdea severity hint span from (Just "") [] +remark :: GHC.Utils.Outputable.Outputable a + => Severity -> String -> Located a -> Idea +remark severity hint from = rawIdeaN severity hint (getLoc from) (unsafePrettyPrint from) Nothing [] + suggest :: (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable b) => String -> Located a -> Located b -> [Refactoring R.SrcSpan] -> Idea suggest = idea Suggestion From bd5cb3cf72d038dc80172421e32fad4803c83209 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gohla?= Date: Sun, 8 Jun 2025 11:21:07 +0100 Subject: [PATCH 2/5] fix test cases, caveat descrition, a little refactor --- hints.md | 6 ++-- src/Hint/NoCapitalisms.hs | 62 +++++++++++++++++++++------------------ 2 files changed, 37 insertions(+), 31 deletions(-) diff --git a/hints.md b/hints.md index 04c5a991d..a9ec73078 100644 --- a/hints.md +++ b/hints.md @@ -1189,12 +1189,12 @@ Does not support refactoring. - +
Example: -type WarpTLSException = () +getFOO = _
Found: -type WarpTLSException = () +getFOO = ...
Suggestion: @@ -1204,7 +1204,7 @@ Suggestion:
Does not support refactoring. 		SuggestionIgnore
diff --git a/src/Hint/NoCapitalisms.hs b/src/Hint/NoCapitalisms.hs index 573b1a443..227198739 100644 --- a/src/Hint/NoCapitalisms.hs +++ b/src/Hint/NoCapitalisms.hs @@ -3,44 +3,48 @@ {- Detect uses of capitalisms - Only allow up to two consecutive capital letters in identifiers. + Only allow up to two consecutive capital letters in top level + identifiers. Identifiers containing underscores are exempted from thus rule. Identifiers of FFI bindings are exempted from thus rule. + Locally bound identifiers and module names are not checked. + -module SSL.Foo -- ??? data LHsDecl -class FOO a where -- ??? -class Foo a where getFOO -- ??? -data Foo = Bar | BAAZ -- ??? -data Foo = B_ar | BAAZ -- ??? +class FOO a where -- @Ignore +class Foo a where getFOO :: Bool +data Foo = Bar | BAAZ -- @Ignore +data Foo = B_ar | BAAZ -- @Ignore data Foo = Bar | B_AAZ -data OTPToken = OTPToken -- ??? +data OTPToken = OTPToken -- @Ignore data OTP_Token = Foo -sendSMS = ... -- ??? -runTLS = ... -- ??? -runTLSSocket = ... -- ??? +sendSMS = _ -- @Ignore +runTLS = _ -- @Ignore +runTLSSocket = _ -- @Ignore runTLS_Socket -newtype TLSSettings = ... -- ??? +newtype TLSSettings = TLSSettings -- @Ignore tlsSettings data CertSettings = CertSettings tlsServerHooks -tlsServerDHEParams = ... -- ??? -type WarpTLSException = () -- ??? +tlsServerDHEParams = _ -- @Ignore +type WarpTLSException = () -- @Ignore get_SMS runCI foreign import ccall _FIREMISSLES :: IO () -let getSMS = x in foo --- ??? +getSMS :: IO () -- @Ignore +gFOO = _ -- @Ignore +geFOO = _ -- @Ignore +getFOO = _ -- @Ignore -} - module Hint.NoCapitalisms(noCapitalismsHint) where -import Hint.Type (DeclHint,remark, Severity (Ignore)) -import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (toList) +import Hint.Type +import Data.List.Extra as E +import Data.List.NonEmpty as NE import Data.Char import Data.Maybe @@ -71,29 +75,31 @@ hasCapitalism :: String -> Bool hasCapitalism s = any isAllUpper (trigrams s) where isAllUpper = all isUpper - trigrams = \case - a:b:c:as -> [a,b,c] : trigrams (c:as) - _otherwise -> [] + +trigrams :: String -> [String] +trigrams = \case + a:b:c:as -> [a,b,c] : trigrams (b:c:as) + _otherwise -> [] --- these are copied from Hint.Naming --- shorten :: LHsDecl GhcPs -> LHsDecl GhcPs shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = - L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) -shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _)))) = - L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) + L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ E.map shortenMatch matches}}) +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = + L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = E.map shortenLGRHS rhss}}) shorten x = x shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = - L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} + L locMatch match {m_grhss = grhss {grhssGRHSs = E.map shortenLGRHS rhss}} shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = L locGRHS (GRHS ttg0 guards (L locExpr dots)) where dots :: HsExpr GhcPs - dots = HsLit EpAnnNotUsed (HsString (SourceText (fsLit "...")) (fsLit "...")) + dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) getNames :: LHsDecl GhcPs -> [String] getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) @@ -105,9 +111,9 @@ getConstructorNames tycld = case tycld of _ -> [] where conNames :: [LConDecl GhcPs] -> [String] - conNames = concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) + conNames = concatMap (E.map unsafePrettyPrint . conNamesInDecl . unLoc) conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] conNamesInDecl ConDeclH98 {con_name = name} = [name] - conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names + conNamesInDecl ConDeclGADT {con_names = names} = NE.toList names From 1a107f5330b55986cfb968566005e62e1b8d4cb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gohla?= Date: Fri, 13 Jun 2025 21:04:16 +0100 Subject: [PATCH 3/5] change criterion to two consecutive capitals --- src/Hint/NoCapitalisms.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/Hint/NoCapitalisms.hs b/src/Hint/NoCapitalisms.hs index 227198739..6353a4494 100644 --- a/src/Hint/NoCapitalisms.hs +++ b/src/Hint/NoCapitalisms.hs @@ -3,8 +3,8 @@ {- Detect uses of capitalisms - Only allow up to two consecutive capital letters in top level - identifiers. + Do not allow two consecutive capital letters in top level + identifiers of types, classes, values and constructors. Identifiers containing underscores are exempted from thus rule. Identifiers of FFI bindings are exempted from thus rule. @@ -12,7 +12,13 @@ Locally bound identifiers and module names are not checked. -data LHsDecl +data IO -- @Ignore +data PersonID = P -- @Ignore +sendIO :: IO () -- @Ignore +sendIO = _ -- @Ignore +class HasIO where -- @Ignore +data Foo = FO -- @Ignore +data LHsDecl -- @Ignore class FOO a where -- @Ignore class Foo a where getFOO :: Bool data Foo = Bar | BAAZ -- @Ignore @@ -72,13 +78,13 @@ hasUnderscore :: String -> Bool hasUnderscore = elem '_' hasCapitalism :: String -> Bool -hasCapitalism s = any isAllUpper (trigrams s) +hasCapitalism s = any isAllUpper (bigrams s) where isAllUpper = all isUpper -trigrams :: String -> [String] -trigrams = \case - a:b:c:as -> [a,b,c] : trigrams (b:c:as) +bigrams :: String -> [String] +bigrams = \case + a:b:as -> [a,b] : bigrams (b:as) _otherwise -> [] --- these are copied from Hint.Naming --- From 82c4457bf258dca168979727eaa8a46c5141570e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gohla?= Date: Fri, 13 Jun 2025 23:29:42 +0100 Subject: [PATCH 4/5] refactor name helper functions --- hlint.cabal | 5 ++-- src/Hint/NameHelpers.hs | 53 +++++++++++++++++++++++++++++++++++++++ src/Hint/Naming.hs | 40 +---------------------------- src/Hint/NoCapitalisms.hs | 50 +++--------------------------------- 4 files changed, 61 insertions(+), 87 deletions(-) create mode 100644 src/Hint/NameHelpers.hs diff --git a/hlint.cabal b/hlint.cabal index cbc787758..81451df6b 100644 --- a/hlint.cabal +++ b/hlint.cabal @@ -158,17 +158,18 @@ library Hint.ListRec Hint.Match Hint.Monad + Hint.NameHelpers Hint.Naming Hint.Negation Hint.NewType + Hint.NoCapitalisms + Hint.NumLiteral Hint.Pattern Hint.Pragma Hint.Restrict Hint.Smell Hint.Type Hint.Unsafe - Hint.NumLiteral - Hint.NoCapitalisms Test.All Test.Annotations Test.InputOutput diff --git a/src/Hint/NameHelpers.hs b/src/Hint/NameHelpers.hs new file mode 100644 index 000000000..c5d34e4bd --- /dev/null +++ b/src/Hint/NameHelpers.hs @@ -0,0 +1,53 @@ +module Hint.NameHelpers where + +import Data.List.Extra as E +import Data.List.NonEmpty as NE +import Data.Maybe + +import GHC.Types.Basic +import GHC.Types.SourceText +import GHC.Data.FastString +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs +import GHC.Types.SrcLoc + +import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +import GHC.Util + +-- | Replace RHSs of top-level value declarations with an ellipsis +-- TODO remove where clauses, these are apparently not caught here +shorten :: LHsDecl GhcPs -> LHsDecl GhcPs +shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = + L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ E.map shortenMatch matches}}) +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = + L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = E.map shortenLGRHS rhss}}) +shorten x = x + +shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) +shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = + L locMatch match {m_grhss = grhss {grhssGRHSs = E.map shortenLGRHS rhss}} + +shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) +shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = + L locGRHS (GRHS ttg0 guards (L locExpr dots)) + where + dots :: HsExpr GhcPs + dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) + +-- | Get the names from all top-level declarations including constructor names +getNames :: LHsDecl GhcPs -> [String] +getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) + +getConstructorNames :: HsDecl GhcPs -> [String] +getConstructorNames tycld = case tycld of + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con] + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons + _ -> [] + where + conNames :: [LConDecl GhcPs] -> [String] + conNames = concatMap (E.map unsafePrettyPrint . conNamesInDecl . unLoc) + + conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] + conNamesInDecl ConDeclH98 {con_name = name} = [name] + conNamesInDecl ConDeclGADT {con_names = names} = NE.toList names diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs index 78d0d7e63..3d57ce724 100644 --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -42,18 +42,15 @@ foreign import ccall hexml_node_child :: IO () module Hint.Naming(namingHint) where +import Hint.NameHelpers import Hint.Type (Idea,DeclHint,suggest,ghcModule) import Data.Generics.Uniplate.DataOnly import Data.List.Extra (nubOrd, isPrefixOf) -import Data.List.NonEmpty (toList) import Data.Data import Data.Char import Data.Maybe import Data.Set qualified as Set -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Data.FastString import GHC.Hs.Decls import GHC.Hs.Extension import GHC.Hs @@ -62,7 +59,6 @@ import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Hs.Decls import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -import GHC.Util namingHint :: DeclHint namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ hsmodDecls $ unLoc (ghcModule modu) @@ -86,40 +82,6 @@ naming seen originalDecl = ] replacedDecl = replaceNames suggestedNames originalDecl -shorten :: LHsDecl GhcPs -> LHsDecl GhcPs -shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = - L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) -shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = - L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) -shorten x = x - -shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) -shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = - L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} - -shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) -shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = - L locGRHS (GRHS ttg0 guards (L locExpr dots)) - where - dots :: HsExpr GhcPs - dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) - -getNames :: LHsDecl GhcPs -> [String] -getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) - -getConstructorNames :: HsDecl GhcPs -> [String] -getConstructorNames tycld = case tycld of - (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con] - (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons - _ -> [] - where - conNames :: [LConDecl GhcPs] -> [String] - conNames = concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) - - conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] - conNamesInDecl ConDeclH98 {con_name = name} = [name] - conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names - isSym :: String -> Bool isSym (x:_) = not $ isAlpha x || x `elem` "_'" isSym _ = False diff --git a/src/Hint/NoCapitalisms.hs b/src/Hint/NoCapitalisms.hs index 6353a4494..3c31c77dd 100644 --- a/src/Hint/NoCapitalisms.hs +++ b/src/Hint/NoCapitalisms.hs @@ -9,9 +9,11 @@ Identifiers containing underscores are exempted from thus rule. Identifiers of FFI bindings are exempted from thus rule. - Locally bound identifiers and module names are not checked. + Locally bound identifiers, field names and module names are not + checked. +data Foo = MkFoo { getID :: String } data IO -- @Ignore data PersonID = P -- @Ignore sendIO :: IO () -- @Ignore @@ -49,22 +51,13 @@ getFOO = _ -- @Ignore module Hint.NoCapitalisms(noCapitalismsHint) where import Hint.Type +import Hint.NameHelpers import Data.List.Extra as E -import Data.List.NonEmpty as NE import Data.Char -import Data.Maybe -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Data.FastString -import GHC.Hs.Decls -import GHC.Hs.Extension import GHC.Hs -import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Hs.Decls -import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -import GHC.Util noCapitalismsHint :: DeclHint noCapitalismsHint _ _ decl = [ remark Ignore "Avoid capitalisms" (reLoc (shorten decl)) @@ -87,39 +80,4 @@ bigrams = \case a:b:as -> [a,b] : bigrams (b:as) _otherwise -> [] ---- these are copied from Hint.Naming --- - -shorten :: LHsDecl GhcPs -> LHsDecl GhcPs -shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = - L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ E.map shortenMatch matches}}) -shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = - L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = E.map shortenLGRHS rhss}}) -shorten x = x - -shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) -shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = - L locMatch match {m_grhss = grhss {grhssGRHSs = E.map shortenLGRHS rhss}} - -shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) -shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = - L locGRHS (GRHS ttg0 guards (L locExpr dots)) - where - dots :: HsExpr GhcPs - dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) - -getNames :: LHsDecl GhcPs -> [String] -getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) - -getConstructorNames :: HsDecl GhcPs -> [String] -getConstructorNames tycld = case tycld of - (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con] - (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons - _ -> [] - where - conNames :: [LConDecl GhcPs] -> [String] - conNames = concatMap (E.map unsafePrettyPrint . conNamesInDecl . unLoc) - - conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] - conNamesInDecl ConDeclH98 {con_name = name} = [name] - conNamesInDecl ConDeclGADT {con_names = names} = NE.toList names From c268f6b51b870621d217b5811e6ebc1822ce7447 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Gohla?= Date: Fri, 13 Jun 2025 23:44:36 +0100 Subject: [PATCH 5/5] remove TODO --- src/Hint/NameHelpers.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Hint/NameHelpers.hs b/src/Hint/NameHelpers.hs index c5d34e4bd..9685ec075 100644 --- a/src/Hint/NameHelpers.hs +++ b/src/Hint/NameHelpers.hs @@ -16,7 +16,6 @@ import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import GHC.Util -- | Replace RHSs of top-level value declarations with an ellipsis --- TODO remove where clauses, these are apparently not caught here shorten :: LHsDecl GhcPs -> LHsDecl GhcPs shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ E.map shortenMatch matches}})