|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | +{-# LANGUAGE LambdaCase #-} |
| 3 | +{- |
| 4 | + Detect uses of capitalisms |
| 5 | +
|
| 6 | + Only allow up to two consecutive capital letters in identifiers. |
| 7 | +
|
| 8 | + Identifiers containing underscores are exempted from thus rule. |
| 9 | + Identifiers of FFI bindings are exempted from thus rule. |
| 10 | +
|
| 11 | +<TEST> |
| 12 | +module SSL.Foo -- ??? |
| 13 | +data LHsDecl |
| 14 | +class FOO a where -- ??? |
| 15 | +class Foo a where getFOO -- ??? |
| 16 | +data Foo = Bar | BAAZ -- ??? |
| 17 | +data Foo = B_ar | BAAZ -- ??? |
| 18 | +data Foo = Bar | B_AAZ |
| 19 | +data OTPToken = OTPToken -- ??? |
| 20 | +data OTP_Token = Foo |
| 21 | +sendSMS = ... -- ??? |
| 22 | +runTLS = ... -- ??? |
| 23 | +runTLSSocket = ... -- ??? |
| 24 | +runTLS_Socket |
| 25 | +newtype TLSSettings = ... -- ??? |
| 26 | +tlsSettings |
| 27 | +data CertSettings = CertSettings |
| 28 | +tlsServerHooks |
| 29 | +tlsServerDHEParams = ... -- ??? |
| 30 | +type WarpTLSException = () -- ??? |
| 31 | +get_SMS |
| 32 | +runCI |
| 33 | +foreign import ccall _FIREMISSLES :: IO () |
| 34 | +let getSMS = x in foo --- ??? |
| 35 | +</TEST> |
| 36 | +-} |
| 37 | + |
| 38 | + |
| 39 | +module Hint.NoCapitalisms(noCapitalismsHint) where |
| 40 | + |
| 41 | +import Hint.Type (DeclHint,remark, Severity (Ignore)) |
| 42 | +import Data.List.Extra (nubOrd) |
| 43 | +import Data.List.NonEmpty (toList) |
| 44 | +import Data.Char |
| 45 | +import Data.Maybe |
| 46 | + |
| 47 | +import GHC.Types.Basic |
| 48 | +import GHC.Types.SourceText |
| 49 | +import GHC.Data.FastString |
| 50 | +import GHC.Hs.Decls |
| 51 | +import GHC.Hs.Extension |
| 52 | +import GHC.Hs |
| 53 | +import GHC.Types.SrcLoc |
| 54 | + |
| 55 | +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls |
| 56 | +import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable |
| 57 | +import GHC.Util |
| 58 | + |
| 59 | +noCapitalismsHint :: DeclHint |
| 60 | +noCapitalismsHint _ _ decl = [ remark Ignore "Avoid capitalisms" (reLoc (shorten decl)) |
| 61 | + | not $ isForD decl |
| 62 | + , name <- nubOrd $ getNames decl |
| 63 | + , not $ hasUnderscore name |
| 64 | + , hasCapitalism name |
| 65 | + ] |
| 66 | + |
| 67 | +hasUnderscore :: String -> Bool |
| 68 | +hasUnderscore = elem '_' |
| 69 | + |
| 70 | +hasCapitalism :: String -> Bool |
| 71 | +hasCapitalism s = any isAllUpper (trigrams s) |
| 72 | + where |
| 73 | + isAllUpper = all isUpper |
| 74 | + trigrams = \case |
| 75 | + a:b:c:as -> [a,b,c] : trigrams (c:as) |
| 76 | + _otherwise -> [] |
| 77 | + |
| 78 | +--- these are copied from Hint.Naming --- |
| 79 | + |
| 80 | +shorten :: LHsDecl GhcPs -> LHsDecl GhcPs |
| 81 | +shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = |
| 82 | + L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) |
| 83 | +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _)))) = |
| 84 | + L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) |
| 85 | +shorten x = x |
| 86 | + |
| 87 | +shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) |
| 88 | +shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = |
| 89 | + L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} |
| 90 | + |
| 91 | +shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) |
| 92 | +shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = |
| 93 | + L locGRHS (GRHS ttg0 guards (L locExpr dots)) |
| 94 | + where |
| 95 | + dots :: HsExpr GhcPs |
| 96 | + dots = HsLit EpAnnNotUsed (HsString (SourceText (fsLit "...")) (fsLit "...")) |
| 97 | + |
| 98 | +getNames :: LHsDecl GhcPs -> [String] |
| 99 | +getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) |
| 100 | + |
| 101 | +getConstructorNames :: HsDecl GhcPs -> [String] |
| 102 | +getConstructorNames tycld = case tycld of |
| 103 | + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con] |
| 104 | + (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons |
| 105 | + _ -> [] |
| 106 | + where |
| 107 | + conNames :: [LConDecl GhcPs] -> [String] |
| 108 | + conNames = concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) |
| 109 | + |
| 110 | + conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs] |
| 111 | + conNamesInDecl ConDeclH98 {con_name = name} = [name] |
| 112 | + conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names |
| 113 | + |
0 commit comments