{-# LANGUAGE ImportQualifiedPost #-}
{-# 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.List.NonEmpty (toList)
import Data.Data
import Data.Char
import Data.Maybe
import Data.Set qualified 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 (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
$ (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [String])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [String]
GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [String]
getNames ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [String])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [String]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls (HsModule GhcPs -> [LHsDecl GhcPs])
-> HsModule GhcPs -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc (ModuleEx -> GenLocated SrcSpan (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
-> Located (HsDecl GhcPs)
-> Located (HsDecl GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use camelCase"
               (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Located (HsDecl GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
originalDecl))
               (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Located (HsDecl GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc (LHsDecl GhcPs -> LHsDecl GhcPs
shorten LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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 a. [a] -> 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 :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
replacedDecl = [(String, String)]
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a. Data a => [(String, String)] -> a -> a
replaceNames [(String, String)]
suggestedNames LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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
_ LIdP GhcPs
_ matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup@(MG XMG GhcPs (LHsExpr GhcPs)
Origin
FromSource (L SrcSpanAnnL
locMatches [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches))))) =
    SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
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 {mg_alts = L locMatches $ map shortenMatch 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
_)))) =
    SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
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 {grhssGRHSs = map shortenLGRHS 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))
_ [XRec GhcPs (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
rhss HsLocalBinds GhcPs
_))) =
    SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS 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
_))) =
    SrcAnn NoEpAnns
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
locGRHS (XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [GuardLStmt GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
ttg0 [GuardLStmt GhcPs]
guards (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locExpr 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 XLitE GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed (XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
HsString (FastString -> SourceText
SourceText (String -> FastString
fsLit String
"...")) (String -> FastString
fsLit String
"..."))

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 (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
unLoc LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
decl)

getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames :: HsDecl GhcPs -> [String]
getConstructorNames HsDecl GhcPs
tycld = case HsDecl GhcPs
tycld of
    (TyClD XTyClD GhcPs
_ (DataDecl XDataDecl GhcPs
_ LIdP GhcPs
_ LHsQTyVars GhcPs
_ LexicalFixity
_ (HsDataDefn XCHsDataDefn GhcPs
_ Maybe (LHsContext GhcPs)
_ Maybe (XRec GhcPs CType)
_ Maybe (LHsKind GhcPs)
_ (NewTypeCon LConDecl GhcPs
con) HsDeriving GhcPs
_))) -> [LConDecl GhcPs] -> [String]
conNames [LConDecl GhcPs
con]
    (TyClD XTyClD GhcPs
_ (DataDecl XDataDecl GhcPs
_ LIdP GhcPs
_ LHsQTyVars GhcPs
_ LexicalFixity
_ (HsDataDefn XCHsDataDefn GhcPs
_ Maybe (LHsContext GhcPs)
_ Maybe (XRec GhcPs CType)
_ Maybe (LHsKind GhcPs)
_ (DataTypeCons Bool
_ [LConDecl GhcPs]
cons) HsDeriving GhcPs
_))) -> [LConDecl GhcPs] -> [String]
conNames [LConDecl GhcPs]
cons
    HsDecl GhcPs
_ -> []
  where
    conNames :: [LConDecl GhcPs] -> [String]
    conNames :: [LConDecl GhcPs] -> [String]
conNames =  (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> [String])
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((GenLocated SrcSpanAnnN RdrName -> String)
-> [GenLocated SrcSpanAnnN RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([GenLocated SrcSpanAnnN RdrName] -> [String])
-> (GenLocated SrcSpanAnnA (ConDecl GhcPs)
    -> [GenLocated SrcSpanAnnN RdrName])
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDecl GhcPs -> [LIdP GhcPs]
ConDecl GhcPs -> [GenLocated SrcSpanAnnN RdrName]
conNamesInDecl (ConDecl GhcPs -> [GenLocated SrcSpanAnnN RdrName])
-> (GenLocated SrcSpanAnnA (ConDecl GhcPs) -> ConDecl GhcPs)
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> [GenLocated SrcSpanAnnN RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcPs) -> ConDecl GhcPs
forall l e. GenLocated l e -> e
unLoc)

    conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs]
    conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs]
conNamesInDecl ConDeclH98  {con_name :: forall pass. ConDecl pass -> LIdP pass
con_name  = LIdP GhcPs
name}  = [LIdP GhcPs
name]
    conNamesInDecl ConDeclGADT {con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (LIdP GhcPs)
names} = NonEmpty (GenLocated SrcSpanAnnN RdrName)
-> [GenLocated SrcSpanAnnN RdrName]
forall a. NonEmpty a -> [a]
Data.List.NonEmpty.toList NonEmpty (LIdP GhcPs)
NonEmpty (GenLocated SrcSpanAnnN RdrName)
names

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 a. Eq a => a -> [a] -> 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_",String
"tasty_"] = 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
$ String -> String
forall a. [a] -> [a]
reverse (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
$ 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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 :: forall a. Data a => [(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