{-# 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 BasicTypes
import FastString
import GHC.Hs.Decls
import GHC.Hs.Extension
import GHC.Hs
import OccName
import 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 (Set String -> LHsDecl GhcPs -> [Idea])
-> Set String -> LHsDecl GhcPs -> [Idea]
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (LHsDecl GhcPs -> [String]) -> [LHsDecl GhcPs] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [String]
getNames ([LHsDecl GhcPs] -> [String]) -> [LHsDecl GhcPs] -> [String]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls (HsModule GhcPs -> [LHsDecl GhcPs])
-> HsModule GhcPs -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> SrcSpanLess (Located (HsModule GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModuleEx -> Located (HsModule GhcPs)
ghcModule ModuleEx
modu)

naming :: Set.Set String -> LHsDecl GhcPs -> [Idea]
naming :: Set String -> LHsDecl GhcPs -> [Idea]
naming Set String
seen LHsDecl GhcPs
originalDecl =
    [ String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use camelCase"
               (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
originalDecl)
               (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
replacedDecl)
               [ -- https://github.com/mpickering/apply-refact/issues/39
               ]
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
suggestedNames
    ]
    where
        suggestedNames :: [(String, String)]
suggestedNames =
            [ (String
originalName, String
suggestedName)
            | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> Bool
isForD LHsDecl GhcPs
originalDecl
            , String
originalName <- [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> [String] -> [String]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
suggestedName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
seen
            ]
        replacedDecl :: LHsDecl GhcPs
replacedDecl = [(String, String)] -> LHsDecl GhcPs -> LHsDecl GhcPs
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 SrcSpan
locDecl (ValD XValD GhcPs
ttg0 bind :: HsBind GhcPs
bind@(FunBind XFunBind GhcPs GhcPs
_ Located (IdP GhcPs)
_ matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup@(MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
locMatches [LMatch GhcPs (LHsExpr GhcPs)]
matches) Origin
FromSource) HsWrapper
_ [Tickish Id]
_))) =
    SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
locDecl (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
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 :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
locMatches ([LMatch GhcPs (LHsExpr GhcPs)]
 -> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ (LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs))
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
shortenMatch [LMatch GhcPs (LHsExpr GhcPs)]
matches}})
shorten (L SrcSpan
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 LHsLocalBinds GhcPs
_) ([Tickish Id], [[Tickish Id]])
_))) =
    SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
locDecl (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
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 (LHsExpr GhcPs)]
grhssGRHSs = (LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> [LGRHS GhcPs (LHsExpr GhcPs)]
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 SrcSpan
locMatch match :: Match GhcPs (LHsExpr GhcPs)
match@(Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
_ [LPat GhcPs]
_ grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss@(GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
rhss LHsLocalBinds GhcPs
_))) =
    SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
locMatch Match GhcPs (LHsExpr GhcPs)
match {m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
grhss {grhssGRHSs :: [LGRHS GhcPs (LHsExpr GhcPs)]
grhssGRHSs = (LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> [LGRHS GhcPs (LHsExpr GhcPs)] -> [LGRHS GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS [LGRHS GhcPs (LHsExpr GhcPs)]
rhss}}
shortenMatch LMatch GhcPs (LHsExpr GhcPs)
x = LMatch GhcPs (LHsExpr GhcPs)
x

shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
shortenLGRHS (L SrcSpan
locGRHS (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
ttg0 [GuardLStmt GhcPs]
guards (L SrcSpan
locExpr HsExpr GhcPs
_))) =
    SrcSpan
-> GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
locGRHS (XCGRHS GhcPs (LHsExpr GhcPs)
-> [GuardLStmt GhcPs]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (LHsExpr GhcPs)
ttg0 [GuardLStmt GhcPs]
guards (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
locExpr HsExpr GhcPs
SrcSpanLess (LHsExpr GhcPs)
dots))
    where
        dots :: HsExpr GhcPs
        dots :: HsExpr GhcPs
dots = XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcPs
noExtField (XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
HsString (String -> SourceText
SourceText String
"...") (String -> FastString
mkFastString String
"..."))
shortenLGRHS LGRHS GhcPs (LHsExpr GhcPs)
x = LGRHS GhcPs (LHsExpr GhcPs)
x

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

getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames (TyClD XTyClD GhcPs
_ (DataDecl XDataDecl GhcPs
_ Located (IdP GhcPs)
_ LHsQTyVars GhcPs
_ LexicalFixity
_ (HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
_ LHsContext GhcPs
_ Maybe (Located CType)
_ Maybe (LHsKind GhcPs)
_ [LConDecl GhcPs]
cons HsDeriving GhcPs
_))) =
    (LConDecl GhcPs -> [String]) -> [LConDecl GhcPs] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Located RdrName -> String) -> [Located RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located RdrName -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([Located RdrName] -> [String])
-> (LConDecl GhcPs -> [Located RdrName])
-> LConDecl GhcPs
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDecl GhcPs -> [Located RdrName]
forall (p :: Pass).
ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]
getConNames (ConDecl GhcPs -> [Located RdrName])
-> (LConDecl GhcPs -> ConDecl GhcPs)
-> LConDecl GhcPs
-> [Located RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDecl GhcPs -> ConDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LConDecl GhcPs]
cons
getConstructorNames HsDecl GhcPs
_ = []

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

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

        g :: String -> String
g String
x | String
x String -> [String] -> Bool
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 Char -> String -> Bool
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 Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
g String
xs
        g (Char
x:String
xs) | Char -> Bool
isAlphaNum Char
x = Char
x Char -> String -> String
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 :: [(String, String)] -> a -> a
replaceNames [(String, String)]
rep = (OccName -> OccName) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi OccName -> OccName
replace
    where
        replace :: OccName -> OccName
        replace :: OccName -> OccName
replace (OccName -> String
forall a. Outputable a => a -> String
unsafePrettyPrint -> String
name) = NameSpace -> String -> OccName
mkOccName NameSpace
srcDataName (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
name (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, String)]
rep