diff --git a/hints.md b/hints.md index 09be1475..a9ec7307 100644 --- a/hints.md +++ b/hints.md @@ -1176,6 +1176,38 @@ Does not support refactoring. +## Builtin NoCapitalisms + + + + + + + + + + + + +
Hint NameHintSeverity
Avoid capitalisms +Example: + +getFOO = _ + +
+Found: + +getFOO = ... + +
+Suggestion: + + + +
+Does not support refactoring. +		Ignore
+ ## Builtin NumLiteral diff --git a/hlint.cabal b/hlint.cabal index c3c8e2d4..81451df6 100644 --- a/hlint.cabal +++ b/hlint.cabal @@ -158,16 +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 Test.All Test.Annotations Test.InputOutput diff --git a/src/Hint/All.hs b/src/Hint/All.hs index 41665c8e..0af41128 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/NameHelpers.hs b/src/Hint/NameHelpers.hs new file mode 100644 index 00000000..9685ec07 --- /dev/null +++ b/src/Hint/NameHelpers.hs @@ -0,0 +1,52 @@ +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 +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 78d0d7e6..3d57ce72 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 new file mode 100644 index 00000000..3c31c77d --- /dev/null +++ b/src/Hint/NoCapitalisms.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{- + Detect uses of capitalisms + + 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. + + 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 +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 +data Foo = B_ar | BAAZ -- @Ignore +data Foo = Bar | B_AAZ +data OTPToken = OTPToken -- @Ignore +data OTP_Token = Foo +sendSMS = _ -- @Ignore +runTLS = _ -- @Ignore +runTLSSocket = _ -- @Ignore +runTLS_Socket +newtype TLSSettings = TLSSettings -- @Ignore +tlsSettings +data CertSettings = CertSettings +tlsServerHooks +tlsServerDHEParams = _ -- @Ignore +type WarpTLSException = () -- @Ignore +get_SMS +runCI +foreign import ccall _FIREMISSLES :: IO () +getSMS :: IO () -- @Ignore +gFOO = _ -- @Ignore +geFOO = _ -- @Ignore +getFOO = _ -- @Ignore + +-} + +module Hint.NoCapitalisms(noCapitalismsHint) where + +import Hint.Type +import Hint.NameHelpers +import Data.List.Extra as E +import Data.Char + +import GHC.Hs + +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls + +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 (bigrams s) + where + isAllUpper = all isUpper + +bigrams :: String -> [String] +bigrams = \case + a:b:as -> [a,b] : bigrams (b:as) + _otherwise -> [] + + diff --git a/src/Idea.hs b/src/Idea.hs index 896e7e5a..1a099290 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