{-# 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 = Foo | BarTest
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 -- semiringLaws = ...
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',isSym,toSrcSpan',ghcModule)
import Data.Generics.Uniplate.Operations
import Data.List.Extra (nubOrd, isPrefixOf)
import Data.Data
import Data.Char
import Data.Maybe
import Refact.Types hiding (RType(Match))
import qualified Data.Set as Set

import BasicTypes
import FastString
import HsDecls
import HsExtension
import HsSyn
import OccName
import SrcLoc

import GHC.Util

namingHint :: DeclHint'
namingHint :: DeclHint'
namingHint _ modu :: 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 seen :: Set String
seen originalDecl :: 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' "Use camelCase"
               (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
originalDecl)
               (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
replacedDecl)
               [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Bind (LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSrcSpan' LHsDecl GhcPs
originalDecl) [] (LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsDecl GhcPs
replacedDecl)]
    | 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 suggestedName :: 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 (LL locDecl :: SrcSpan
locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) FromSource) _ _))) =
    SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL 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 :: Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
locMatches (SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
 -> Located [LMatch GhcPs (LHsExpr GhcPs)])
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
-> Located [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)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
matches}})
shorten (LL locDecl :: SrcSpan
locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =
    SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL 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 x :: 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 (LL locMatch :: SrcSpan
locMatch match :: SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =
    SrcSpan
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
locMatch SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
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 x :: 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 (LL locGRHS :: SrcSpan
locGRHS (GRHS ttg0 guards (LL locExpr _))) =
    SrcSpan
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL 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 SrcSpanLess (LHsExpr GhcPs)
HsExpr 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 NoExt
XLitE GhcPs
NoExt (XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
HsString (String -> SourceText
SourceText "...") (String -> FastString
mkFastString "..."))
shortenLGRHS x :: LGRHS GhcPs (LHsExpr GhcPs)
x = LGRHS GhcPs (LHsExpr GhcPs)
x

getNames :: LHsDecl GhcPs -> [String]
getNames :: LHsDecl GhcPs -> [String]
getNames decl :: 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 _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons :: [LConDecl GhcPs]
cons _))) =
    (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 pass. ConDecl pass -> [Located (IdP pass)]
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 _ = []

suggestName :: String -> Maybe String
suggestName :: String -> Maybe String
suggestName original :: 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) ["prop_","case_","unit_","test_","spec_","scprop_","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 '_' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
drp '#' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
drp '\'' (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 '_' String
original
        drp :: a -> [a] -> [a]
drp x :: 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 xs :: String
xs = String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
g String
ys
            where (us :: String
us,ys :: 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
== '_') String
xs

        g :: String -> String
g x :: String
x | String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["_","'","_'"] = String
x
        g (a :: Char
a:x :: Char
x:xs :: String
xs) | Char
a Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "_'" 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 (x :: Char
x:xs :: 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 rep :: [(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