Add a hint to avoid capitalisms

hints.md

@@ -1176,6 +1176,38 @@ Does not support refactoring.
 </tr>
 </table>
 
+## Builtin NoCapitalisms
+
+<table>
+<tr>
+<th>Hint Name</th>
+<th>Hint</th>
+<th>Severity</th>
+</tr>
+<tr>
+<td>Avoid capitalisms</td>
+<td>
+Example: 
+<code>
+getFOO = _
+</code>
+<br>
+Found:
+<code>
+getFOO = ...
+</code>
+<br>
+Suggestion:
+<code>
+
+</code>
+<br>
+Does not support refactoring.
+</td>
+<td>Ignore</td>
+</tr>
+</table>
+
 ## Builtin NumLiteral
 
 <table>

hlint.cabal

@@ -168,6 +168,7 @@ library
         Hint.Type
         Hint.Unsafe
         Hint.NumLiteral
+        Hint.NoCapitalisms
         Test.All
         Test.Annotations
         Test.InputOutput

src/Hint/All.hs

@@ -34,14 +34,15 @@ 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.
 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}

src/Hint/NoCapitalisms.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-
+    Detect uses of capitalisms
+
+    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.
+
+<TEST>
+data LHsDecl
+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
+</TEST>
+-}
+
+module Hint.NoCapitalisms(noCapitalismsHint) where
+
+import Hint.Type
+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))
+                             | 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 :: 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 $ 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
+

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