{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-
    Suggest the use of camelCase

    Only permit:
    _*[A-Za-z]*_*#*'*

    Apply this to things that would get exported by default only
    Also allow prop_ as it's a standard QuickCheck idiom
    Also allow case_ as it's a standard test-framework-th idiom
    Also allow test_ as it's a standard tasty-th idiom
    Also allow numbers separated by _
    Also don't suggest anything mentioned elsewhere in the module
    Don't suggest for FFI, since they match their C names

<TEST>
data Yes = Foo | Bar'Test
data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar
data No = a :::: b
data Yes = Foo {bar_cap :: Int}
data No = FOO | BarBAR | BarBBar
yes_foo = yes_foo + yes_foo -- yesFoo = ...
yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ...
no = 1 where yes_foo = 2
a -== b = 1
myTest = 1; my_test = 1
semiring'laws = 1
data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB
case_foo = 1
test_foo = 1
cast_foo = 1 -- castFoo = ...
replicateM_ = 1
_foo__ = 1
section_1_1 = 1
runMutator# = 1
foreign import ccall hexml_node_child :: IO ()
</TEST>
-}


module Hint.Naming(namingHint) where

import Hint.Type (Idea,DeclHint,suggest,ghcModule)
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra (nubOrd, isPrefixOf)
import Data.Data
import Data.Char
import Data.Maybe
import qualified Data.Set 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
import GHC.Types.Name.Occurrence
import GHC.Types.SrcLoc

import Language.Haskell.GhclibParserEx.GHC.Hs.Decls
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import GHC.Util

namingHint :: DeclHint
namingHint :: DeclHint
namingHint Scope
_ ModuleEx
modu = Set String -> LHsDecl GhcPs -> [Idea]
naming forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [String]
getNames forall a b. (a -> b) -> a -> b
$ HsModule -> [LHsDecl GhcPs]
hsmodDecls forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc (ModuleEx -> Located HsModule
ghcModule ModuleEx
modu)

naming :: Set.Set String -> LHsDecl GhcPs -> [Idea]
naming :: Set String -> LHsDecl GhcPs -> [Idea]
naming Set String
seen LHsDecl GhcPs
originalDecl =
    [ forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use camelCase"
               (forall a e. LocatedAn a e -> Located e
reLoc (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
originalDecl))
               (forall a e. LocatedAn a e -> Located e
reLoc (LHsDecl GhcPs -> LHsDecl GhcPs
shorten GenLocated SrcSpanAnnA (HsDecl GhcPs)
replacedDecl))
               [ -- https://github.com/mpickering/apply-refact/issues/39
               ]
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
suggestedNames
    ]
    where
        suggestedNames :: [(String, String)]
suggestedNames =
            [ (String
originalName, String
suggestedName)
            | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> Bool
isForD LHsDecl GhcPs
originalDecl
            , String
originalName <- forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> [String]
getNames LHsDecl GhcPs
originalDecl
            , Just String
suggestedName <- [String -> Maybe String
suggestName String
originalName]
            , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String
suggestedName forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
seen
            ]
        replacedDecl :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
replacedDecl = forall a. Data a => [(String, String)] -> a -> a
replaceNames [(String, String)]
suggestedNames LHsDecl GhcPs
originalDecl

shorten :: LHsDecl GhcPs -> LHsDecl GhcPs
shorten :: LHsDecl GhcPs -> LHsDecl GhcPs
shorten (L SrcSpanAnnA
locDecl (ValD XValD GhcPs
ttg0 bind :: HsBind GhcPs
bind@(FunBind XFunBind GhcPs GhcPs
_ XRec GhcPs (IdP GhcPs)
_ matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup@(MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpanAnnL
locMatches [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches) Origin
FromSource) [CoreTickish]
_))) =
    forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locDecl (forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
ttg0 HsBind GhcPs
bind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup {mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
mg_alts = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
locMatches forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
shortenMatch [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches}})
shorten (L SrcSpanAnnA
locDecl (ValD XValD GhcPs
ttg0 bind :: HsBind GhcPs
bind@(PatBind XPatBind GhcPs GhcPs
_ LPat GhcPs
_ grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss@(GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
rhss HsLocalBinds GhcPs
_) ([CoreTickish], [[CoreTickish]])
_))) =
    forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locDecl (forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
ttg0 HsBind GhcPs
bind {pat_rhs :: GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs = GRHSs GhcPs (LHsExpr GhcPs)
grhss {grhssGRHSs :: [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
grhssGRHSs = forall a b. (a -> b) -> [a] -> [b]
map LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS [LGRHS GhcPs (LHsExpr GhcPs)]
rhss}})
shorten LHsDecl GhcPs
x = LHsDecl GhcPs
x

shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
shortenMatch (L SrcSpanAnnA
locMatch match :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match@(Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
_ [LPat GhcPs]
_ grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss@(GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rhss HsLocalBinds GhcPs
_))) =
    forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match {m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss {grhssGRHSs :: [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
grhssGRHSs = forall a b. (a -> b) -> [a] -> [b]
map LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rhss}}

shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS (L SrcAnn NoEpAnns
locGRHS (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ttg0 [GuardLStmt GhcPs]
guards (L SrcSpanAnnA
locExpr HsExpr GhcPs
_))) =
    forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
locGRHS (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ttg0 [GuardLStmt GhcPs]
guards (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locExpr HsExpr GhcPs
dots))
    where
        dots :: HsExpr GhcPs
        dots :: HsExpr GhcPs
dots = forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall ann. EpAnn ann
EpAnnNotUsed (forall x. XHsString x -> FastString -> HsLit x
HsString (String -> SourceText
SourceText String
"...") (String -> FastString
mkFastString String
"..."))

getNames :: LHsDecl GhcPs -> [String]
getNames :: LHsDecl GhcPs -> [String]
getNames LHsDecl GhcPs
decl = forall a. Maybe a -> [a]
maybeToList (LHsDecl GhcPs -> Maybe String
declName LHsDecl GhcPs
decl) forall a. [a] -> [a] -> [a]
++ HsDecl GhcPs -> [String]
getConstructorNames (forall l e. GenLocated l e -> e
unLoc LHsDecl GhcPs
decl)

getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames (TyClD XTyClD GhcPs
_ (DataDecl XDataDecl GhcPs
_ XRec GhcPs (IdP GhcPs)
_ LHsQTyVars GhcPs
_ LexicalFixity
_ (HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
_ Maybe (LHsContext GhcPs)
_ Maybe (XRec GhcPs CType)
_ Maybe (LHsKind GhcPs)
_ [LConDecl GhcPs]
cons HsDeriving GhcPs
_))) =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> String
unsafePrettyPrint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {pass}. ConDecl pass -> [XRec pass (IdP pass)]
getConNames' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LConDecl GhcPs]
cons
    where
      getConNames' :: ConDecl pass -> [XRec pass (IdP pass)]
getConNames' ConDeclH98  {con_name :: forall pass. ConDecl pass -> LIdP pass
con_name  = XRec pass (IdP pass)
name}  = [XRec pass (IdP pass)
name]
      getConNames' ConDeclGADT {con_names :: forall {pass}. ConDecl pass -> [XRec pass (IdP pass)]
con_names = [XRec pass (IdP pass)]
names} = [XRec pass (IdP pass)]
names
      getConNames' XConDecl{} = []

getConstructorNames HsDecl GhcPs
_ = []

isSym :: String -> Bool
isSym :: String -> Bool
isSym (Char
x:String
_) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_'"
isSym String
_ = Bool
False

suggestName :: String -> Maybe String
suggestName :: String -> Maybe String
suggestName String
original
    | String -> Bool
isSym String
original Bool -> Bool -> Bool
|| Bool
good Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isLower String
original) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isDigit String
original Bool -> Bool -> Bool
||
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
original) [String
"prop_",String
"case_",String
"unit_",String
"test_",String
"spec_",String
"scprop_",String
"hprop_",String
"tasty_"] = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String
f String
original
    where
        good :: Bool
good = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum forall a b. (a -> b) -> a -> b
$ forall {a}. Eq a => a -> [a] -> [a]
drp Char
'_' forall a b. (a -> b) -> a -> b
$ forall {a}. Eq a => a -> [a] -> [a]
drp Char
'#' forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\'') forall a b. (a -> b) -> a -> b
$ forall {a}. Eq a => a -> [a] -> [a]
drp Char
'_' String
original
        drp :: a -> [a] -> [a]
drp a
x = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== a
x)

        f :: String -> String
f String
xs = String
us forall a. [a] -> [a] -> [a]
++ String -> String
g String
ys
            where (String
us,String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
== Char
'_') String
xs

        g :: String -> String
g String
x | String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"_",String
"'",String
"_'"] = String
x
        g (Char
a:Char
x:String
xs) | Char
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_'" Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
x = Char -> Char
toUpper Char
x forall a. a -> [a] -> [a]
: String -> String
g String
xs
        g (Char
x:String
xs) | Char -> Bool
isAlphaNum Char
x = Char
x forall a. a -> [a] -> [a]
: String -> String
g String
xs
                 | Bool
otherwise = String -> String
g String
xs
        g [] = []

replaceNames :: Data a => [(String, String)] -> a -> a
replaceNames :: forall a. Data a => [(String, String)] -> a -> a
replaceNames [(String, String)]
rep = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi OccName -> OccName
replace
    where
        replace :: OccName -> OccName
        replace :: OccName -> OccName
replace (forall a. Outputable a => a -> String
unsafePrettyPrint -> String
name) = NameSpace -> String -> OccName
mkOccName NameSpace
srcDataName forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
name forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, String)]
rep