Prevent accidental Cthulhu summons

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

@@ -85,6 +85,7 @@ library
     , text
     , transformers
     , unordered-containers
+    , hyphenation
 
   default-language:   Haskell2010
   default-extensions:

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

@@ -1,58 +1,204 @@
 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           GhcPlugins (charTy, maybeTyCon)
 import           Name
 import           TcType
+import           Text.Hyphenation (hyphenate, english_US)
 import           TyCon
 import           Type
-import           TysWiredIn (listTyCon, pairTyCon, unitTyCon)
+import           TysWiredIn (listTyCon, unitTyCon)
+import           Wingman.GHC (tcTyVar_maybe)
 
 
 ------------------------------------------------------------------------------
--- | Use type information to create a reasonable name.
-mkTyName :: Type -> String
--- eg. mkTyName (a -> B) = "fab"
-mkTyName (tcSplitFunTys -> ([a@(isFunTy -> False)], b))
-  = "f" ++ mkTyName a ++ mkTyName b
--- eg. mkTyName (a -> b -> C) = "f_C"
-mkTyName (tcSplitFunTys -> (_:_, b))
-  = "f_" ++ mkTyName b
--- eg. mkTyName (Either A B) = "eab"
-mkTyName (splitTyConApp_maybe -> Just (c, args))
-  = mkTyConName c ++ foldMap mkTyName args
--- eg. mkTyName (f a) = "fa"
-mkTyName (tcSplitAppTys -> (t, args@(_:_)))
-  = mkTyName t ++ foldMap mkTyName args
--- eg. mkTyName a = "a"
-mkTyName (getTyVar_maybe -> Just tv)
-  = occNameString $ occName tv
--- eg. mkTyName (forall x. y) = "y"
-mkTyName (tcSplitSigmaTy -> (_:_, _, t))
-  = mkTyName t
-mkTyName _ = "x"
+-- | A classification of a variable, for which we have specific naming rules.
+-- A variable can have multiple purposes simultaneously.
+data Purpose
+  = Function [Type] Type
+  | Predicate
+  | Continuation
+  | Integral
+  | Number
+  | String
+  | List Type
+  | Maybe Type
+  | TyConned TyCon [Type]
+    -- ^ Something of the form @TC a b c@
+  | TyVarred TyVar [Type]
+    -- ^ Something of the form @m a b c@
+
+pattern IsPredicate :: Type
+pattern IsPredicate <-
+  (tcSplitFunTys -> ([isFunTy -> False], isBoolTy -> True))
+
+pattern IsFunction :: [Type] -> Type -> Type
+pattern IsFunction args res <-
+  (tcSplitFunTys -> (args@(_:_), res))
+
+pattern IsString :: Type
+pattern IsString <-
+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True]))
+
+pattern IsMaybe :: Type -> Type
+pattern IsMaybe a <-
+  (splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a]))
+
+pattern IsList :: Type -> Type
+pattern IsList a <-
+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a]))
+
+pattern IsTyConned :: TyCon -> [Type] -> Type
+pattern IsTyConned tc args <-
+  (splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args))
+
+pattern IsTyVarred :: TyVar -> [Type] -> Type
+pattern IsTyVarred v args <-
+  (tcSplitAppTys -> (tcTyVar_maybe -> Just v, args))
+
+
+------------------------------------------------------------------------------
+-- | Get the 'Purpose's of a type. A type can have multiple purposes
+-- simultaneously, so the order of purposes in this function corresponds to the
+-- precedence of that naming rule. Which means, eg, that if a type is both
+-- a 'Predicate' and a 'Function', we should prefer to use the predicate naming
+-- rules, since they come first.
+getPurposes :: Type -> [Purpose]
+getPurposes ty = mconcat
+  [ [ Predicate         | IsPredicate         <- [ty] ]
+  , [ Function args res | IsFunction args res <- [ty] ]
+  , with (isIntegerTy ty) [ Integral, Number          ]
+  , with (isIntTy ty)     [ Integral, Number          ]
+  , [ Number            | isFloatingTy ty             ]
+  , [ String            | isStringTy ty               ]
+  , [ Maybe a           | IsMaybe a           <- [ty] ]
+  , [ List a            | IsList a            <- [ty] ]
+  , [ TyVarred v args   | IsTyVarred v args   <- [ty] ]
+  , [ TyConned tc args  | IsTyConned tc args  <- [ty]
+                        , not (isTupleTyCon tc)
+                        , tc /= listTyCon             ]
+  ]
+
+
+------------------------------------------------------------------------------
+-- | Return 'mempty' if the give bool is false.
+with :: Monoid a => Bool -> a -> a
+with False _ = mempty
+with True a = a
+
+
+------------------------------------------------------------------------------
+-- | Names we can give functions
+functionNames :: [String]
+functionNames = ["f", "g", "h"]
+
+
+------------------------------------------------------------------------------
+-- | Get a ranked ordering of names for a given purpose.
+purposeToName :: Purpose -> [String]
+purposeToName (Function args res)
+  | Just tv_args <- traverse tcTyVar_maybe $ args <> pure res
+  = fmap (<> foldMap (occNameString . occName) tv_args) functionNames
+purposeToName (Function _ _) = functionNames
+purposeToName Predicate = pure "p"
+purposeToName Continuation = pure "k"
+purposeToName Integral = ["n", "i", "j"]
+purposeToName Number = ["x", "y", "z", "w"]
+purposeToName String = ["s", "str"]
+purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t
+purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t
+purposeToName (TyVarred tv args)
+  | Just tv_args <- traverse tcTyVar_maybe args
+  = pure $ foldMap (occNameString . occName) $ tv : tv_args
+purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv
+purposeToName (TyConned tc args@(_:_))
+  | Just tv_args <- traverse tcTyVar_maybe args
+  = [ mkTyConName tc
+      -- We insert primes to everything later, but it gets the lowest
+      -- precedence. Here we'd like to prefer it over the more specific type
+      -- name.
+    , mkTyConName tc <> "'"
+    , mconcat
+      [ mkTyConName tc
+      , bool mempty "_" $ length (mkTyConName tc) > 1
+      , foldMap (occNameString . occName) tv_args
+      ]
+    ]
+purposeToName (TyConned tc _)
+  = pure
+  $ mkTyConName tc
+
+
+mkTyName :: Type -> [String]
+mkTyName = purposeToName <=< getPurposes
 
 
 ------------------------------------------------------------------------------
 -- | Get a good name for a type constructor.
 mkTyConName :: TyCon -> String
 mkTyConName tc
-  | tc == listTyCon = "l_"
-  | tc == pairTyCon = "p_"
-  | tc == unitTyCon = "unit"
-  | otherwise
+  | tc == unitTyCon = "u"
+  | isSymOcc occ
       = take 1
       . fmap toLower
       . filterReplace isSymbol      's'
       . filterReplace isPunctuation 'p'
-      . occNameString
-      $ getOccName tc
+      $ name
+  | camels@(_:_:_) <- camelTerms name
+      = foldMap (fmap toLower . take 1) camels
+  | otherwise
+      = getStem
+      $ fmap toLower
+      $ name
+  where
+    occ = getOccName tc
+    name = occNameString occ
+
+
+------------------------------------------------------------------------------
+-- | Split a string into its camel case components.
+camelTerms :: String -> [String]
+camelTerms = split (== '@') . camelTo2 '@'
+
+
+------------------------------------------------------------------------------
+-- | A stem of a string is either a special-case shortened form, or a shortened
+-- first syllable. If the string is one syllable, we take the full word if it's
+-- short, or just the first two characters if it's long. Otherwise, just take
+-- the first syllable.
+--
+-- NOTE: There's no rhyme or reason here, I just experimented until I got
+-- results that were reasonably consistent with the names I would give things.
+getStem :: String -> String
+getStem str =
+  let s = stem str
+   in case (s == str, length str) of
+        (False, _)             -> s
+        (True, (<= 3) -> True) -> str
+        _                      -> take 2 str
+
+------------------------------------------------------------------------------
+-- | Get a special-case stem, or, failing that, give back the first syllable.
+stem :: String -> String
+stem "char" = "c"
+stem "function" = "func"
+stem "bool" = "b"
+stem "either" = "e"
+stem "text" = "txt"
+stem s = join $ take 1 $ hyphenate english_US s
 
 
 ------------------------------------------------------------------------------
@@ -67,11 +213,23 @@ mkGoodName
     :: Set OccName  -- ^ Bindings in scope; used to ensure we don't shadow anything
     -> Type       -- ^ The type to produce a name for
     -> OccName
-mkGoodName in_scope t =
-  let tn = mkTyName t
-   in mkVarOcc $ case S.member (mkVarOcc tn) in_scope of
-        True  -> tn ++ show (length in_scope)
-        False -> tn
+mkGoodName in_scope (mkTyName -> tn)
+  = mkVarOcc
+  . fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn)
+  . getFirst
+  . foldMap (\n -> bool (pure n) mempty $ check n)
+  $ tn <> fmap (<> "'") tn
+  where
+    check n = S.member (mkVarOcc n) in_scope
+
+
+------------------------------------------------------------------------------
+-- | Given a desired name, compute a new name for it based on how many names in
+-- scope conflict with it. Eg, if we want to name something @x@, but already
+-- have @x@, @x'@ and @x2@ in scope, we will give back @x3@.
+mkNumericSuffix :: Set OccName -> String -> String
+mkNumericSuffix s nm =
+  mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s
 
 
 ------------------------------------------------------------------------------

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

@@ -298,7 +298,7 @@ destructAll :: TacticsM ()
 destructAll = do
   jdg <- goal
   let args = fmap fst
-           $ sortOn (Down . snd)
+           $ sort
            $ mapMaybe (\(hi, prov) ->
               case prov of
                 TopLevelArgPrv _ idx _ -> pure (hi, idx)

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

@@ -17,10 +17,11 @@ spec = do
   let destructTest = goldenTest Destruct
 
   describe "golden" $ do
-    destructTest "gadt" 7 17 "GoldenGADTDestruct.hs"
-    destructTest "gadt" 8 17 "GoldenGADTDestructCoercion.hs"
-    destructTest "a"    7 25 "SplitPattern.hs"
-    destructTest "a"    6 18 "DestructPun.hs"
+    destructTest "gadt"  7 17 "GoldenGADTDestruct.hs"
+    destructTest "gadt"  8 17 "GoldenGADTDestructCoercion.hs"
+    destructTest "a"     7 25 "SplitPattern.hs"
+    destructTest "a"     6 18 "DestructPun.hs"
+    destructTest "fp"   31 14 "DestructCthulhu.hs"
 
   describe "layout" $ do
     destructTest "b"  4  3 "LayoutBind.hs"

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

@@ -9,5 +9,5 @@ instance ( Functor f
            -- dictionary, we can get Wingman to generate the right definition.
          , Functor (Fix f)
          ) => Functor (Fix f) where
-  fmap fab (Fix fffa) = Fix (fmap (fmap fab) fffa)
+  fmap fab (Fix f) = Fix (fmap (fmap fab) f)
 

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

@@ -1,6 +1,6 @@
 zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)]
 zip_it_up_and_zip_it_out _ [] = []
 zip_it_up_and_zip_it_out [] (_ : _) = []
-zip_it_up_and_zip_it_out (a : l_a5) (b : l_b3)
-  = (a, b) : zip_it_up_and_zip_it_out l_a5 l_b3
+zip_it_up_and_zip_it_out (a : as') (b : bs')
+  = (a, b) : zip_it_up_and_zip_it_out as' bs'
 

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

@@ -1,5 +1,5 @@
 and :: Bool -> Bool -> Bool
 and False False = _
-and True False = _
 and False True = _
+and True False = _
 and True True = _

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

@@ -2,26 +2,26 @@ data ABC = A | B | C
 
 many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> ()
 many () (Left a) False Nothing A = _
-many () (Right b5) False Nothing A = _
+many () (Left a) False (Just abc') A = _
+many () (Right b') False Nothing A = _
+many () (Right b') False (Just abc') A = _
 many () (Left a) True Nothing A = _
-many () (Right b5) True Nothing A = _
-many () (Left a6) False (Just a) A = _
-many () (Right b6) False (Just a) A = _
-many () (Left a6) True (Just a) A = _
-many () (Right b6) True (Just a) A = _
+many () (Left a) True (Just abc') A = _
+many () (Right b') True Nothing A = _
+many () (Right b') True (Just abc') A = _
 many () (Left a) False Nothing B = _
-many () (Right b5) False Nothing B = _
+many () (Left a) False (Just abc') B = _
+many () (Right b') False Nothing B = _
+many () (Right b') False (Just abc') B = _
 many () (Left a) True Nothing B = _
-many () (Right b5) True Nothing B = _
-many () (Left a6) False (Just a) B = _
-many () (Right b6) False (Just a) B = _
-many () (Left a6) True (Just a) B = _
-many () (Right b6) True (Just a) B = _
+many () (Left a) True (Just abc') B = _
+many () (Right b') True Nothing B = _
+many () (Right b') True (Just abc') B = _
 many () (Left a) False Nothing C = _
-many () (Right b5) False Nothing C = _
+many () (Left a) False (Just abc') C = _
+many () (Right b') False Nothing C = _
+many () (Right b') False (Just abc') C = _
 many () (Left a) True Nothing C = _
-many () (Right b5) True Nothing C = _
-many () (Left a6) False (Just a) C = _
-many () (Right b6) False (Just a) C = _
-many () (Left a6) True (Just a) C = _
-many () (Right b6) True (Just a) C = _
+many () (Left a) True (Just abc') C = _
+many () (Right b') True Nothing C = _
+many () (Right b') True (Just abc') C = _

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

@@ -1,6 +1,6 @@
 and :: (a, b) -> Bool -> Bool -> Bool
 and (a, b) False False = _
-and (a, b) True False = _
 and (a, b) False True = _
+and (a, b) True False = _
 and (a, b) True True = _