{-# LANGUAGE CPP #-}
module Wingman.Naming where
import Control.Arrow
import Control.Monad.State.Strict
import Data.Aeson (camelTo2)
import Data.Bool (bool)
import Data.Char
import Data.List (isPrefixOf)
import Data.List.Extra (split)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Traversable
import Development.IDE.GHC.Compat.Core hiding (IsFunction)
import Text.Hyphenation (hyphenate, english_US)
import Wingman.GHC (tcTyVar_maybe)
#if __GLASGOW_HASKELL__ >= 900
import GHC.Tc.Utils.TcType
#endif
data Purpose
= Function [Type] Type
| Predicate
| Continuation
| Integral
| Number
| String
| List Type
| Maybe Type
| TyConned TyCon [Type]
| TyVarred TyVar [Type]
pattern IsPredicate :: Type
pattern $mIsPredicate :: forall r. Type -> (Void# -> r) -> (Void# -> r) -> r
IsPredicate <-
(tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True))
pattern IsFunction :: [Type] -> Type -> Type
pattern $mIsFunction :: forall r. Type -> ([Type] -> Type -> r) -> (Void# -> r) -> r
IsFunction args res <-
(first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res))
pattern IsString :: Type
pattern $mIsString :: forall r. Type -> (Void# -> r) -> (Void# -> r) -> r
IsString <-
(splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True]))
pattern IsMaybe :: Type -> Type
pattern $mIsMaybe :: forall r. Type -> (Type -> r) -> (Void# -> r) -> r
IsMaybe a <-
(splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a]))
pattern IsList :: Type -> Type
pattern $mIsList :: forall r. Type -> (Type -> r) -> (Void# -> r) -> r
IsList a <-
(splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a]))
pattern IsTyConned :: TyCon -> [Type] -> Type
pattern $mIsTyConned :: forall r. Type -> (TyCon -> [Type] -> r) -> (Void# -> r) -> r
IsTyConned tc args <-
(splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args))
pattern IsTyVarred :: TyVar -> [Type] -> Type
pattern $mIsTyVarred :: forall r. Type -> (TyVar -> [Type] -> r) -> (Void# -> r) -> r
IsTyVarred v args <-
(tcSplitAppTys -> (tcTyVar_maybe -> Just v, args))
getPurposes :: Type -> [Purpose]
getPurposes :: Type -> [Purpose]
getPurposes Type
ty = [[Purpose]] -> [Purpose]
forall a. Monoid a => [a] -> a
mconcat
[ [ Purpose
Predicate | Type
IsPredicate <- [Type
ty] ]
, [ [Type] -> Type -> Purpose
Function [Type]
args Type
res | IsFunction [Type]
args Type
res <- [Type
ty] ]
, Bool -> [Purpose] -> [Purpose]
forall a. Monoid a => Bool -> a -> a
with (Type -> Bool
isIntegerTy Type
ty) [ Purpose
Integral, Purpose
Number ]
, Bool -> [Purpose] -> [Purpose]
forall a. Monoid a => Bool -> a -> a
with (Type -> Bool
isIntTy Type
ty) [ Purpose
Integral, Purpose
Number ]
, [ Purpose
Number | Type -> Bool
isFloatingTy Type
ty ]
, [ Purpose
String | Type -> Bool
isStringTy Type
ty ]
, [ Type -> Purpose
Maybe Type
a | IsMaybe Type
a <- [Type
ty] ]
, [ Type -> Purpose
List Type
a | IsList Type
a <- [Type
ty] ]
, [ TyVar -> [Type] -> Purpose
TyVarred TyVar
v [Type]
args | IsTyVarred TyVar
v [Type]
args <- [Type
ty] ]
, [ TyCon -> [Type] -> Purpose
TyConned TyCon
tc [Type]
args | IsTyConned TyCon
tc [Type]
args <- [Type
ty]
, Bool -> Bool
not (TyCon -> Bool
isTupleTyCon TyCon
tc)
, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
listTyCon ]
]
with :: Monoid a => Bool -> a -> a
with :: Bool -> a -> a
with Bool
False a
_ = a
forall a. Monoid a => a
mempty
with Bool
True a
a = a
a
functionNames :: [String]
functionNames :: [String]
functionNames = [String
"f", String
"g", String
"h"]
purposeToName :: Purpose -> [String]
purposeToName :: Purpose -> [String]
purposeToName (Function [Type]
args Type
res)
| Just [TyVar]
tv_args <- (Type -> Maybe TyVar) -> [Type] -> Maybe [TyVar]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TyVar
tcTyVar_maybe ([Type] -> Maybe [TyVar]) -> [Type] -> Maybe [TyVar]
forall a b. (a -> b) -> a -> b
$ [Type]
args [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> Type -> [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
res
= (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (TyVar -> String) -> [TyVar] -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OccName -> String
occNameString (OccName -> String) -> (TyVar -> OccName) -> TyVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> OccName
forall name. HasOccName name => name -> OccName
occName) [TyVar]
tv_args) [String]
functionNames
purposeToName (Function [Type]
_ Type
_) = [String]
functionNames
purposeToName Purpose
Predicate = String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"p"
purposeToName Purpose
Continuation = String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"k"
purposeToName Purpose
Integral = [String
"n", String
"i", String
"j"]
purposeToName Purpose
Number = [String
"x", String
"y", String
"z", String
"w"]
purposeToName Purpose
String = [String
"s", String
"str"]
purposeToName (List Type
t) = (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"s") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Purpose -> [String]
purposeToName (Purpose -> [String]) -> [Purpose] -> [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> [Purpose]
getPurposes Type
t
purposeToName (Maybe Type
t) = (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"m_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Purpose -> [String]
purposeToName (Purpose -> [String]) -> [Purpose] -> [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> [Purpose]
getPurposes Type
t
purposeToName (TyVarred TyVar
tv [Type]
args)
| Just [TyVar]
tv_args <- (Type -> Maybe TyVar) -> [Type] -> Maybe [TyVar]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TyVar
tcTyVar_maybe [Type]
args
= String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (TyVar -> String) -> [TyVar] -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OccName -> String
occNameString (OccName -> String) -> (TyVar -> OccName) -> TyVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> OccName
forall name. HasOccName name => name -> OccName
occName) ([TyVar] -> String) -> [TyVar] -> String
forall a b. (a -> b) -> a -> b
$ TyVar
tv TyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
: [TyVar]
tv_args
purposeToName (TyVarred TyVar
tv [Type]
_) = String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ TyVar -> OccName
forall name. HasOccName name => name -> OccName
occName TyVar
tv
purposeToName (TyConned TyCon
tc args :: [Type]
args@(Type
_:[Type]
_))
| Just [TyVar]
tv_args <- (Type -> Maybe TyVar) -> [Type] -> Maybe [TyVar]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TyVar
tcTyVar_maybe [Type]
args
= [ TyCon -> String
mkTyConName TyCon
tc
, TyCon -> String
mkTyConName TyCon
tc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
, [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ TyCon -> String
mkTyConName TyCon
tc
, String -> String -> Bool -> String
forall a. a -> a -> Bool -> a
bool String
forall a. Monoid a => a
mempty String
"_" (Bool -> String) -> Bool -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> String
mkTyConName TyCon
tc) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
, (TyVar -> String) -> [TyVar] -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OccName -> String
occNameString (OccName -> String) -> (TyVar -> OccName) -> TyVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> OccName
forall name. HasOccName name => name -> OccName
occName) [TyVar]
tv_args
]
]
purposeToName (TyConned TyCon
tc [Type]
_)
= String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ TyCon -> String
mkTyConName TyCon
tc
mkTyName :: Type -> [String]
mkTyName :: Type -> [String]
mkTyName = Purpose -> [String]
purposeToName (Purpose -> [String]) -> (Type -> [Purpose]) -> Type -> [String]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> [Purpose]
getPurposes
mkTyConName :: TyCon -> String
mkTyConName :: TyCon -> String
mkTyConName TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = String
"u"
| OccName -> Bool
isSymOcc OccName
occ
= Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Char -> String -> String
forall a. (a -> Bool) -> a -> [a] -> [a]
filterReplace Char -> Bool
isSymbol Char
's'
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Char -> String -> String
forall a. (a -> Bool) -> a -> [a] -> [a]
filterReplace Char -> Bool
isPunctuation Char
'p'
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
name
| camels :: [String]
camels@(String
_:String
_:[String]
_) <- String -> [String]
camelTerms String
name
= (String -> String) -> [String] -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1) [String]
camels
| Bool
otherwise
= String -> String
getStem
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower String
name
where
occ :: OccName
occ = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc
name :: String
name = OccName -> String
occNameString OccName
occ
camelTerms :: String -> [String]
camelTerms :: String -> [String]
camelTerms = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@') (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
camelTo2 Char
'@'
getStem :: String -> String
getStem :: String -> String
getStem String
str =
let s :: String
s = String -> String
stem String
str
in case (String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) of
(Bool
False, Int
_) -> String
s
(Bool
True, (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3) -> Bool
True) -> String
str
(Bool, Int)
_ -> Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 String
str
stem :: String -> String
stem :: String -> String
stem String
"char" = String
"c"
stem String
"function" = String
"func"
stem String
"bool" = String
"b"
stem String
"either" = String
"e"
stem String
"text" = String
"txt"
stem String
s = [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Hyphenator -> String -> [String]
hyphenate Hyphenator
english_US String
s
filterReplace :: (a -> Bool) -> a -> [a] -> [a]
filterReplace :: (a -> Bool) -> a -> [a] -> [a]
filterReplace a -> Bool
f a
r = (a -> a) -> [a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool a
a a
r (Bool -> a) -> Bool -> a
forall a b. (a -> b) -> a -> b
$ a -> Bool
f a
a)
mkGoodName
:: Set OccName
-> Type
-> OccName
mkGoodName :: Set OccName -> Type -> OccName
mkGoodName Set OccName
in_scope (Type -> [String]
mkTyName -> [String]
tn)
= String -> OccName
mkVarOcc
(String -> OccName) -> ([String] -> String) -> [String] -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Set OccName -> String -> String
mkNumericSuffix Set OccName
in_scope (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"x" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
tn)
(Maybe String -> String)
-> ([String] -> Maybe String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First String -> Maybe String
forall a. First a -> Maybe a
getFirst
(First String -> Maybe String)
-> ([String] -> First String) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> First String) -> [String] -> First String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\String
n -> First String -> First String -> Bool -> First String
forall a. a -> a -> Bool -> a
bool (String -> First String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
n) First String
forall a. Monoid a => a
mempty (Bool -> First String) -> Bool -> First String
forall a b. (a -> b) -> a -> b
$ String -> Bool
check String
n)
([String] -> OccName) -> [String] -> OccName
forall a b. (a -> b) -> a -> b
$ [String]
tn [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'") [String]
tn
where
check :: String -> Bool
check String
n = OccName -> Set OccName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (String -> OccName
mkVarOcc String
n) Set OccName
in_scope
mkNumericSuffix :: Set OccName -> String -> String
mkNumericSuffix :: Set OccName -> String -> String
mkNumericSuffix Set OccName
s String
nm =
String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
nm (String -> String) -> ([OccName] -> String) -> [OccName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([OccName] -> Int) -> [OccName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OccName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([OccName] -> Int) -> ([OccName] -> [OccName]) -> [OccName] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> Bool) -> [OccName] -> [OccName]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
nm (String -> Bool) -> (OccName -> String) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString) ([OccName] -> String) -> [OccName] -> String
forall a b. (a -> b) -> a -> b
$ Set OccName -> [OccName]
forall a. Set a -> [a]
S.toList Set OccName
s
mkManyGoodNames
:: (Traversable t)
=> Set OccName
-> t Type
-> t OccName
mkManyGoodNames :: Set OccName -> t Type -> t OccName
mkManyGoodNames Set OccName
in_scope t Type
args =
(State (Set OccName) (t OccName) -> Set OccName -> t OccName)
-> Set OccName -> State (Set OccName) (t OccName) -> t OccName
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set OccName) (t OccName) -> Set OccName -> t OccName
forall s a. State s a -> s -> a
evalState Set OccName
in_scope (State (Set OccName) (t OccName) -> t OccName)
-> State (Set OccName) (t OccName) -> t OccName
forall a b. (a -> b) -> a -> b
$ t Type
-> (Type -> StateT (Set OccName) Identity OccName)
-> State (Set OccName) (t OccName)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for t Type
args ((Type -> StateT (Set OccName) Identity OccName)
-> State (Set OccName) (t OccName))
-> (Type -> StateT (Set OccName) Identity OccName)
-> State (Set OccName) (t OccName)
forall a b. (a -> b) -> a -> b
$ \Type
at -> do
Set OccName
in_scope <- StateT (Set OccName) Identity (Set OccName)
forall s (m :: * -> *). MonadState s m => m s
get
let n :: OccName
n = Set OccName -> Type -> OccName
mkGoodName Set OccName
in_scope Type
at
(Set OccName -> Set OccName) -> StateT (Set OccName) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set OccName -> Set OccName) -> StateT (Set OccName) Identity ())
-> (Set OccName -> Set OccName) -> StateT (Set OccName) Identity ()
forall a b. (a -> b) -> a -> b
$ OccName -> Set OccName -> Set OccName
forall a. Ord a => a -> Set a -> Set a
S.insert OccName
n
OccName -> StateT (Set OccName) Identity OccName
forall (f :: * -> *) a. Applicative f => a -> f a
pure OccName
n
getInScope :: Map OccName a -> [OccName]
getInScope :: Map OccName a -> [OccName]
getInScope = Map OccName a -> [OccName]
forall k a. Map k a -> [k]
M.keys