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 _ -> f (PatBind a b) c
x -> x
where
dots = Var an $ UnQual an $ Ident an "..."
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 || not (any isLower x) || "prop_" `isPrefixOf` x || "case_" `isPrefixOf` x]
where
good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' x
drp x = dropWhile (== x)
f xs = us ++ g ys
where (us,ys) = span (== '_') xs
g x | x `elem` ["_","'","_'"] = x
g (a:x:xs) | a `elem` "_'" && 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