hlint-1.7: src/Hint/Naming.hs

{-# 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 don't suggest anything mentioned elsewhere in the module

<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 Yes = Foo{barCap :: Int}
data No = FOO | BarBAR | BarBBar
yes_foo = yes_foo + yes_foo -- yesFoo = ...
no = 1 where yes_foo = 2
a -== b = 1
myTest = 1; my_test = 1
</TEST>
-}


module Hint.Naming(namingHint) where

import Hint.Type
import Data.List
import Data.Char
import Data.Maybe
import Util
import qualified Data.Set as Set


namingHint :: DeclHint
namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu]

naming :: Set.Set String -> Decl_ -> [Idea]
naming seen x = [warn "Use camelCase" x2 (replaceNames res x2) | notNull res]
    where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]
          x2 = shorten x


shorten :: Decl_ -> Decl_
shorten x = case x of
    FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d]
    PatBind a b c d _ -> f (PatBind a b c) d
    x -> x
    where
        dots = Var an $ UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol
        f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing
        f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing


getNames :: Decl_ -> [String]
getNames x = case x of
    FunBind{} -> name
    PatBind{} -> name
    TypeDecl{} -> name
    DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]
    GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons]
    TypeFamDecl{} -> name
    DataFamDecl{} -> name
    ClassDecl{} -> name
    _ -> []
    where
        name = [fromNamed x]

        f (ConDecl _ x _) = [x]
        f (InfixConDecl _ _ x _) = [x]
        f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys]


suggestName :: String -> Maybe String
suggestName x = listToMaybe [f x | not $ isSym x || good || "prop_" `isPrefixOf` x]
    where
        good = all isAlphaNum $ drp '_' $ drp '\'' $ reverse $ dropWhile (== '_') x
        drp x ys = if [x] `isPrefixOf` ys then tail ys else ys

        f xs = us ++ g ys
            where (us,ys) = span (== '_') xs

        g x | x `elem` ["_","'","_'"] = x
        g ('_':x:xs) | isAlphaNum x = toUpper x : g xs
        g (x:xs) | isAlphaNum x = x : g xs
                 | otherwise = g xs
        g [] = []


replaceNames :: Biplate a (Name S) => [(String,String)] -> a -> a
replaceNames rep = descendBi f
    where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep
          f x = x