Skip to content

Commit aa9b3c6

Browse files
isovectormergify[bot]
isovector
and
mergify[bot]
authored
Prevent accidental Cthulhu summons (#1760)
* Significantly improved naming system * Use naming purposes * Use camel case information for shortening long ids * Update tests * Haddock and minor prime fix for tycons * Fix tests * Add Cthulhu test * That whitespace test is still inconsistent between versions of ghc * Fix test Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 98ffe94 commit aa9b3c6

34 files changed

+333
-88
lines changed

‎plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ library
8585
, text
8686
, transformers
8787
, unordered-containers
88+
, hyphenation
8889

8990
default-language: Haskell2010
9091
default-extensions:

‎plugins/hls-tactics-plugin/src/Wingman/Naming.hs

Lines changed: 191 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,58 +1,204 @@
11
module Wingman.Naming where
22

3+
import Control.Arrow
34
import Control.Monad.State.Strict
5+
import Data.Aeson (camelTo2)
46
import Data.Bool (bool)
57
import Data.Char
8+
import Data.List (isPrefixOf)
9+
import Data.List.Extra (split)
610
import Data.Map (Map)
711
import qualified Data.Map as M
12+
import Data.Maybe (listToMaybe, fromMaybe)
13+
import Data.Monoid
814
import Data.Set (Set)
915
import qualified Data.Set as S
1016
import Data.Traversable
17+
import GhcPlugins (charTy, maybeTyCon)
1118
import Name
1219
import TcType
20+
import Text.Hyphenation (hyphenate, english_US)
1321
import TyCon
1422
import Type
15-
import TysWiredIn (listTyCon, pairTyCon, unitTyCon)
23+
import TysWiredIn (listTyCon, unitTyCon)
24+
import Wingman.GHC (tcTyVar_maybe)
1625

1726

1827
------------------------------------------------------------------------------
19-
-- | Use type information to create a reasonable name.
20-
mkTyName :: Type -> String
21-
-- eg. mkTyName (a -> B) = "fab"
22-
mkTyName (tcSplitFunTys -> ([a@(isFunTy -> False)], b))
23-
= "f" ++ mkTyName a ++ mkTyName b
24-
-- eg. mkTyName (a -> b -> C) = "f_C"
25-
mkTyName (tcSplitFunTys -> (_:_, b))
26-
= "f_" ++ mkTyName b
27-
-- eg. mkTyName (Either A B) = "eab"
28-
mkTyName (splitTyConApp_maybe -> Just (c, args))
29-
= mkTyConName c ++ foldMap mkTyName args
30-
-- eg. mkTyName (f a) = "fa"
31-
mkTyName (tcSplitAppTys -> (t, args@(_:_)))
32-
= mkTyName t ++ foldMap mkTyName args
33-
-- eg. mkTyName a = "a"
34-
mkTyName (getTyVar_maybe -> Just tv)
35-
= occNameString $ occName tv
36-
-- eg. mkTyName (forall x. y) = "y"
37-
mkTyName (tcSplitSigmaTy -> (_:_, _, t))
38-
= mkTyName t
39-
mkTyName _ = "x"
28+
-- | A classification of a variable, for which we have specific naming rules.
29+
-- A variable can have multiple purposes simultaneously.
30+
data Purpose
31+
= Function [Type] Type
32+
| Predicate
33+
| Continuation
34+
| Integral
35+
| Number
36+
| String
37+
| List Type
38+
| Maybe Type
39+
| TyConned TyCon [Type]
40+
-- ^ Something of the form @TC a b c@
41+
| TyVarred TyVar [Type]
42+
-- ^ Something of the form @m a b c@
43+
44+
pattern IsPredicate :: Type
45+
pattern IsPredicate <-
46+
(tcSplitFunTys -> ([isFunTy -> False], isBoolTy -> True))
47+
48+
pattern IsFunction :: [Type] -> Type -> Type
49+
pattern IsFunction args res <-
50+
(tcSplitFunTys -> (args@(_:_), res))
51+
52+
pattern IsString :: Type
53+
pattern IsString <-
54+
(splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True]))
55+
56+
pattern IsMaybe :: Type -> Type
57+
pattern IsMaybe a <-
58+
(splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a]))
59+
60+
pattern IsList :: Type -> Type
61+
pattern IsList a <-
62+
(splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a]))
63+
64+
pattern IsTyConned :: TyCon -> [Type] -> Type
65+
pattern IsTyConned tc args <-
66+
(splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args))
67+
68+
pattern IsTyVarred :: TyVar -> [Type] -> Type
69+
pattern IsTyVarred v args <-
70+
(tcSplitAppTys -> (tcTyVar_maybe -> Just v, args))
71+
72+
73+
------------------------------------------------------------------------------
74+
-- | Get the 'Purpose's of a type. A type can have multiple purposes
75+
-- simultaneously, so the order of purposes in this function corresponds to the
76+
-- precedence of that naming rule. Which means, eg, that if a type is both
77+
-- a 'Predicate' and a 'Function', we should prefer to use the predicate naming
78+
-- rules, since they come first.
79+
getPurposes :: Type -> [Purpose]
80+
getPurposes ty = mconcat
81+
[ [ Predicate | IsPredicate <- [ty] ]
82+
, [ Function args res | IsFunction args res <- [ty] ]
83+
, with (isIntegerTy ty) [ Integral, Number ]
84+
, with (isIntTy ty) [ Integral, Number ]
85+
, [ Number | isFloatingTy ty ]
86+
, [ String | isStringTy ty ]
87+
, [ Maybe a | IsMaybe a <- [ty] ]
88+
, [ List a | IsList a <- [ty] ]
89+
, [ TyVarred v args | IsTyVarred v args <- [ty] ]
90+
, [ TyConned tc args | IsTyConned tc args <- [ty]
91+
, not (isTupleTyCon tc)
92+
, tc /= listTyCon ]
93+
]
94+
95+
96+
------------------------------------------------------------------------------
97+
-- | Return 'mempty' if the give bool is false.
98+
with :: Monoid a => Bool -> a -> a
99+
with False _ = mempty
100+
with True a = a
101+
102+
103+
------------------------------------------------------------------------------
104+
-- | Names we can give functions
105+
functionNames :: [String]
106+
functionNames = ["f", "g", "h"]
107+
108+
109+
------------------------------------------------------------------------------
110+
-- | Get a ranked ordering of names for a given purpose.
111+
purposeToName :: Purpose -> [String]
112+
purposeToName (Function args res)
113+
| Just tv_args <- traverse tcTyVar_maybe $ args <> pure res
114+
= fmap (<> foldMap (occNameString . occName) tv_args) functionNames
115+
purposeToName (Function _ _) = functionNames
116+
purposeToName Predicate = pure "p"
117+
purposeToName Continuation = pure "k"
118+
purposeToName Integral = ["n", "i", "j"]
119+
purposeToName Number = ["x", "y", "z", "w"]
120+
purposeToName String = ["s", "str"]
121+
purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t
122+
purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t
123+
purposeToName (TyVarred tv args)
124+
| Just tv_args <- traverse tcTyVar_maybe args
125+
= pure $ foldMap (occNameString . occName) $ tv : tv_args
126+
purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv
127+
purposeToName (TyConned tc args@(_:_))
128+
| Just tv_args <- traverse tcTyVar_maybe args
129+
= [ mkTyConName tc
130+
-- We insert primes to everything later, but it gets the lowest
131+
-- precedence. Here we'd like to prefer it over the more specific type
132+
-- name.
133+
, mkTyConName tc <> "'"
134+
, mconcat
135+
[ mkTyConName tc
136+
, bool mempty "_" $ length (mkTyConName tc) > 1
137+
, foldMap (occNameString . occName) tv_args
138+
]
139+
]
140+
purposeToName (TyConned tc _)
141+
= pure
142+
$ mkTyConName tc
143+
144+
145+
mkTyName :: Type -> [String]
146+
mkTyName = purposeToName <=< getPurposes
40147

41148

42149
------------------------------------------------------------------------------
43150
-- | Get a good name for a type constructor.
44151
mkTyConName :: TyCon -> String
45152
mkTyConName tc
46-
| tc == listTyCon = "l_"
47-
| tc == pairTyCon = "p_"
48-
| tc == unitTyCon = "unit"
49-
| otherwise
153+
| tc == unitTyCon = "u"
154+
| isSymOcc occ
50155
= take 1
51156
. fmap toLower
52157
. filterReplace isSymbol 's'
53158
. filterReplace isPunctuation 'p'
54-
. occNameString
55-
$ getOccName tc
159+
$ name
160+
| camels@(_:_:_) <- camelTerms name
161+
= foldMap (fmap toLower . take 1) camels
162+
| otherwise
163+
= getStem
164+
$ fmap toLower
165+
$ name
166+
where
167+
occ = getOccName tc
168+
name = occNameString occ
169+
170+
171+
------------------------------------------------------------------------------
172+
-- | Split a string into its camel case components.
173+
camelTerms :: String -> [String]
174+
camelTerms = split (== '@') . camelTo2 '@'
175+
176+
177+
------------------------------------------------------------------------------
178+
-- | A stem of a string is either a special-case shortened form, or a shortened
179+
-- first syllable. If the string is one syllable, we take the full word if it's
180+
-- short, or just the first two characters if it's long. Otherwise, just take
181+
-- the first syllable.
182+
--
183+
-- NOTE: There's no rhyme or reason here, I just experimented until I got
184+
-- results that were reasonably consistent with the names I would give things.
185+
getStem :: String -> String
186+
getStem str =
187+
let s = stem str
188+
in case (s == str, length str) of
189+
(False, _) -> s
190+
(True, (<= 3) -> True) -> str
191+
_ -> take 2 str
192+
193+
------------------------------------------------------------------------------
194+
-- | Get a special-case stem, or, failing that, give back the first syllable.
195+
stem :: String -> String
196+
stem "char" = "c"
197+
stem "function" = "func"
198+
stem "bool" = "b"
199+
stem "either" = "e"
200+
stem "text" = "txt"
201+
stem s = join $ take 1 $ hyphenate english_US s
56202

57203

58204
------------------------------------------------------------------------------
@@ -67,11 +213,23 @@ mkGoodName
67213
:: Set OccName -- ^ Bindings in scope; used to ensure we don't shadow anything
68214
-> Type -- ^ The type to produce a name for
69215
-> OccName
70-
mkGoodName in_scope t =
71-
let tn = mkTyName t
72-
in mkVarOcc $ case S.member (mkVarOcc tn) in_scope of
73-
True -> tn ++ show (length in_scope)
74-
False -> tn
216+
mkGoodName in_scope (mkTyName -> tn)
217+
= mkVarOcc
218+
. fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn)
219+
. getFirst
220+
. foldMap (\n -> bool (pure n) mempty $ check n)
221+
$ tn <> fmap (<> "'") tn
222+
where
223+
check n = S.member (mkVarOcc n) in_scope
224+
225+
226+
------------------------------------------------------------------------------
227+
-- | Given a desired name, compute a new name for it based on how many names in
228+
-- scope conflict with it. Eg, if we want to name something @x@, but already
229+
-- have @x@, @x'@ and @x2@ in scope, we will give back @x3@.
230+
mkNumericSuffix :: Set OccName -> String -> String
231+
mkNumericSuffix s nm =
232+
mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s
75233

76234

77235
------------------------------------------------------------------------------

‎plugins/hls-tactics-plugin/src/Wingman/Tactics.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -298,7 +298,7 @@ destructAll :: TacticsM ()
298298
destructAll = do
299299
jdg <- goal
300300
let args = fmap fst
301-
$ sortOn (Down . snd)
301+
$ sort
302302
$ mapMaybe (\(hi, prov) ->
303303
case prov of
304304
TopLevelArgPrv _ idx _ -> pure (hi, idx)

‎plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -17,10 +17,11 @@ spec = do
1717
let destructTest = goldenTest Destruct
1818

1919
describe "golden" $ do
20-
destructTest "gadt" 7 17 "GoldenGADTDestruct.hs"
21-
destructTest "gadt" 8 17 "GoldenGADTDestructCoercion.hs"
22-
destructTest "a" 7 25 "SplitPattern.hs"
23-
destructTest "a" 6 18 "DestructPun.hs"
20+
destructTest "gadt" 7 17 "GoldenGADTDestruct.hs"
21+
destructTest "gadt" 8 17 "GoldenGADTDestructCoercion.hs"
22+
destructTest "a" 7 25 "SplitPattern.hs"
23+
destructTest "a" 6 18 "DestructPun.hs"
24+
destructTest "fp" 31 14 "DestructCthulhu.hs"
2425

2526
describe "layout" $ do
2627
destructTest "b" 4 3 "LayoutBind.hs"

‎plugins/hls-tactics-plugin/test/golden/AutoThetaFix.hs.expected

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,5 +9,5 @@ instance ( Functor f
99
-- dictionary, we can get Wingman to generate the right definition.
1010
, Functor (Fix f)
1111
) => Functor (Fix f) where
12-
fmap fab (Fix fffa) = Fix (fmap (fmap fab) fffa)
12+
fmap fab (Fix f) = Fix (fmap (fmap fab) f)
1313

‎plugins/hls-tactics-plugin/test/golden/AutoZip.hs.expected

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)]
22
zip_it_up_and_zip_it_out _ [] = []
33
zip_it_up_and_zip_it_out [] (_ : _) = []
4-
zip_it_up_and_zip_it_out (a : l_a5) (b : l_b3)
5-
= (a, b) : zip_it_up_and_zip_it_out l_a5 l_b3
4+
zip_it_up_and_zip_it_out (a : as') (b : bs')
5+
= (a, b) : zip_it_up_and_zip_it_out as' bs'
66

‎plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs.expected

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
and :: Bool -> Bool -> Bool
22
and False False = _
3-
and True False = _
43
and False True = _
4+
and True False = _
55
and True True = _

‎plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs.expected

Lines changed: 18 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -2,26 +2,26 @@ data ABC = A | B | C
22

33
many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> ()
44
many () (Left a) False Nothing A = _
5-
many () (Right b5) False Nothing A = _
5+
many () (Left a) False (Just abc') A = _
6+
many () (Right b') False Nothing A = _
7+
many () (Right b') False (Just abc') A = _
68
many () (Left a) True Nothing A = _
7-
many () (Right b5) True Nothing A = _
8-
many () (Left a6) False (Just a) A = _
9-
many () (Right b6) False (Just a) A = _
10-
many () (Left a6) True (Just a) A = _
11-
many () (Right b6) True (Just a) A = _
9+
many () (Left a) True (Just abc') A = _
10+
many () (Right b') True Nothing A = _
11+
many () (Right b') True (Just abc') A = _
1212
many () (Left a) False Nothing B = _
13-
many () (Right b5) False Nothing B = _
13+
many () (Left a) False (Just abc') B = _
14+
many () (Right b') False Nothing B = _
15+
many () (Right b') False (Just abc') B = _
1416
many () (Left a) True Nothing B = _
15-
many () (Right b5) True Nothing B = _
16-
many () (Left a6) False (Just a) B = _
17-
many () (Right b6) False (Just a) B = _
18-
many () (Left a6) True (Just a) B = _
19-
many () (Right b6) True (Just a) B = _
17+
many () (Left a) True (Just abc') B = _
18+
many () (Right b') True Nothing B = _
19+
many () (Right b') True (Just abc') B = _
2020
many () (Left a) False Nothing C = _
21-
many () (Right b5) False Nothing C = _
21+
many () (Left a) False (Just abc') C = _
22+
many () (Right b') False Nothing C = _
23+
many () (Right b') False (Just abc') C = _
2224
many () (Left a) True Nothing C = _
23-
many () (Right b5) True Nothing C = _
24-
many () (Left a6) False (Just a) C = _
25-
many () (Right b6) False (Just a) C = _
26-
many () (Left a6) True (Just a) C = _
27-
many () (Right b6) True (Just a) C = _
25+
many () (Left a) True (Just abc') C = _
26+
many () (Right b') True Nothing C = _
27+
many () (Right b') True (Just abc') C = _

‎plugins/hls-tactics-plugin/test/golden/DestructAllNonVarTopMatch.hs.expected

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
and :: (a, b) -> Bool -> Bool -> Bool
22
and (a, b) False False = _
3-
and (a, b) True False = _
43
and (a, b) False True = _
4+
and (a, b) True False = _
55
and (a, b) True True = _
66

0 commit comments

Comments
 (0)