diff --git a/hints.md b/hints.md index da06294a..abcac49d 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 fbfd0069..e2a53ebc 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 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/NoCapitalisms.hs b/src/Hint/NoCapitalisms.hs new file mode 100644 index 00000000..573b1a44 --- /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 e0267312..735a3859 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, Note(..), showNotes, @@ -99,6 +99,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