Add typeApplications option for restricted functions

Author: terror

README.md

@@ -430,6 +430,16 @@ This:
 * Requires that `Unsafe` must always be imported qualified, and can't be aliased.
 * Forbids `import qualified Prelude` and `import Prelude qualified` (with or without explicit import list).
 
+For restricted functions, you can also control visible type applications with `typeApplications` set to either `'required'` or `'forbidden'`:
+
+```yaml
+- functions:
+  - {name: fromIntegral, typeApplications: required}
+  - {name: show, typeApplications: required}
+```
+
+This flags any call to `fromIntegral` or `show` that omits visible type arguments.
+
 You can match on module names using [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards. Module names are treated like file paths, except that periods in module names are like directory separators in file paths. So `**.*Spec` will match `Spec`, `PreludeSpec`, `Data.ListSpec`, and many more. But `*Spec` won't match `Data.ListSpec` because of the separator. See [the filepattern library](https://hackage.haskell.org/package/filepattern) for a more thorough description of the matching.
 
 Restrictions are unified between wildcard and specific matches. With `asRequired`, `importStyle` and `qualifiedStyle` fields, the more specific option takes precedence. The list fields are merged. With multiple wildcard matches, the precedence between them is not guaranteed (but in practice, names are sorted in the reverse lexicograpic order, and the first one wins -- which hopefully means the more specific one more often than not)

data/type_applications.yaml

@@ -0,0 +1,5 @@
+- functions:
+  - {name: fromIntegral, typeApplications: required}
+  - {name: Just, typeApplications: required}
+  - {name: id, typeApplications: forbidden}
+  - {name: Left, typeApplications: forbidden}

src/Config/Type.hs

@@ -9,7 +9,7 @@
 module Config.Type(
     Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),
     Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..),
-    RestrictImportStyle(..), QualifiedStyle(..),
+    RestrictImportStyle(..), QualifiedStyle(..), RestrictTypeApp(..),
     defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType
     ) where
 
@@ -147,6 +147,16 @@ data RestrictImportStyle
   | ImportStyleUnrestricted
   deriving Show
 
+data RestrictTypeApp
+  = TypeAppRequired
+  | TypeAppForbidden
+  deriving (Eq, Show)
+
+instance Semigroup RestrictTypeApp where
+  TypeAppRequired <> TypeAppRequired = TypeAppRequired
+  TypeAppForbidden <> TypeAppForbidden = TypeAppForbidden
+  x <> y = error $ "Incompatible type application restrictions: " ++ show (x, y)
+
 data QualifiedStyle
   = QualifiedStylePre
   | QualifiedStylePost
@@ -161,6 +171,7 @@ data Restrict = Restrict
     ,restrictAsRequired :: Alt Maybe Bool -- for RestrictModule only
     ,restrictImportStyle :: Alt Maybe RestrictImportStyle -- for RestrictModule only
     ,restrictQualifiedStyle :: Alt Maybe QualifiedStyle -- for RestrictModule only
+    ,restrictTypeApp :: Maybe RestrictTypeApp -- for RestrictFunction only
     ,restrictWithin :: [(String, String)]
     ,restrictIdents :: RestrictIdents -- for RestrictModule only, what identifiers can be imported from it
     ,restrictMessage :: Maybe String

src/Config/Yaml.hs

@@ -343,7 +343,19 @@ parseRestrict restrictType v = do
         Just def -> do
             b <- parseBool def
             allowFields v ["default"]
-            pure $ Restrict restrictType b [] mempty mempty mempty mempty [] NoRestrictIdents Nothing
+            pure Restrict
+              { restrictType = restrictType
+              , restrictDefault = b
+              , restrictName = []
+              , restrictAs = mempty
+              , restrictAsRequired = mempty
+              , restrictImportStyle = mempty
+              , restrictQualifiedStyle = mempty
+              , restrictTypeApp = Nothing
+              , restrictWithin = []
+              , restrictIdents = NoRestrictIdents
+              , restrictMessage = Nothing
+              }
         Nothing -> do
             restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString
             restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)
@@ -361,6 +373,10 @@ parseRestrict restrictType v = do
               , ("post"        , QualifiedStylePost)
               , ("unrestricted", QualifiedStyleUnrestricted)
               ]
+            restrictTypeApp <- parseFieldOpt "typeApplications" v >>= maybeParseEnum
+              [ ("required" , TypeAppRequired)
+              , ("forbidden", TypeAppForbidden)
+              ]
 
 
             restrictBadIdents <- parseFieldOpt "badidents" v
@@ -375,9 +391,10 @@ parseRestrict restrictType v = do
             restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString
             allowFields v $
                 ["name", "within", "message"] ++
-                if restrictType == RestrictModule
-                    then ["as", "asRequired", "importStyle", "qualifiedStyle", "badidents", "only"]
-                    else []
+                case restrictType of
+                    RestrictModule -> ["as", "asRequired", "importStyle", "qualifiedStyle", "badidents", "only"]
+                    RestrictFunction -> ["typeApplications"]
+                    _ -> []
             pure Restrict{restrictDefault=True,..}
 
 parseWithin :: Val -> Parser [(String, String)] -- (module, decl)

src/Hint/Restrict.hs

@@ -87,11 +87,21 @@ instance Semigroup RestrictItem where
       <> RestrictItem y1 y2 y3 y4 y5 y6 y7
       = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4) (x5<>y5) (x6<>y6) (x7<>y7)
 
+data RestrictFunctionItem = RestrictFunctionItem
+    {rfiWithin :: [(String, String)]
+    ,rfiMessage :: Maybe String
+    ,rfiTypeApp :: Maybe RestrictTypeApp
+    }
+
+instance Semigroup RestrictFunctionItem where
+    RestrictFunctionItem a1 a2 a3 <> RestrictFunctionItem b1 b2 b3 =
+        RestrictFunctionItem (a1 <> b1) (a2 <> b2) (a3 <> b3)
+
 -- Contains a map from module (Nothing if the rule is unqualified) to (within, message), so that we can
 -- distinguish functions with the same name.
 -- For example, this allows us to have separate rules for "Data.Map.fromList" and "Data.Set.fromList".
 -- Using newtype rather than type because we want to define (<>) as 'Map.unionWith (<>)'.
-newtype RestrictFunction = RestrictFun (Map.Map (Maybe String) ([(String, String)], Maybe String))
+newtype RestrictFunction = RestrictFun (Map.Map (Maybe String) RestrictFunctionItem)
 
 instance Semigroup RestrictFunction where
     RestrictFun m1 <> RestrictFun m2 = RestrictFun (Map.unionWith (<>) m1 m2)
@@ -104,7 +114,11 @@ restrictions settings = (rFunction, rOthers)
     where
         (map snd -> rfs, ros) = partition ((== RestrictFunction) . fst) [(restrictType x, x) | SettingRestrict x <- settings]
         rFunction = (all restrictDefault rfs, Map.fromListWith (<>) [mkRf s r | r <- rfs, s <- restrictName r])
-        mkRf s Restrict{..} = (name, RestrictFun $ Map.singleton modu (restrictWithin, restrictMessage))
+        mkRf s Restrict{..} = (name, RestrictFun $ Map.singleton modu RestrictFunctionItem
+            { rfiWithin = restrictWithin
+            , rfiMessage = restrictMessage
+            , rfiTypeApp = restrictTypeApp
+            })
           where
             -- Parse module and name from s. module = Nothing if the rule is unqualified.
             (modu, name) = first (fmap NonEmpty.init . NonEmpty.nonEmpty) (breakEnd (== '.') s)
@@ -271,14 +285,57 @@ importListToIdents =
 
 checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea]
 checkFunctions scope modu decls (def, mp) =
-    [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLoc x) (reLoc x) []){ideaDecl = [dname]}
+    [ (ideaMessage rfiMessage $ ideaNoTo $ warn hint (reLoc x) (reLoc x) []){ideaDecl = [dname]}
     | d <- decls
     , let dname = fromMaybe "" (declName d)
     , x <- universeBi d :: [LocatedN RdrName]
     , let xMods = possModules scope x
-    , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction mp x xMods)
-    , not $ within modu dname withins
+    , let RestrictFunctionItem{..} = fromMaybe defaultRestrictFunction (findFunction mp x xMods)
+    , let withinOk = within modu dname rfiWithin
+    , let typeAppOk = maybe True (\req -> typeAppSatisfies req typeAppHeads (locA $ getLoc x)) rfiTypeApp
+    , let hint = case () of
+            _ | not withinOk -> "Avoid restricted function"
+              | otherwise    -> typeAppHint rfiTypeApp
+    , not withinOk || not typeAppOk
     ]
+  where
+    typeAppHeads = visibleTypeAppHeads decls
+    defaultRestrictFunction = RestrictFunctionItem [("","") | def] Nothing Nothing
+
+typeAppHint :: Maybe RestrictTypeApp -> String
+typeAppHint (Just TypeAppRequired) = "Use visible type application"
+typeAppHint (Just TypeAppForbidden) = "Avoid visible type application"
+typeAppHint Nothing = "Avoid restricted function"
+
+typeAppSatisfies :: RestrictTypeApp -> Set.Set SrcSpanD -> SrcSpan -> Bool
+typeAppSatisfies TypeAppRequired heads = (`Set.member` heads) . SrcSpanD
+typeAppSatisfies TypeAppForbidden heads = (`Set.notMember` heads) . SrcSpanD
+
+visibleTypeAppHeads :: [LHsDecl GhcPs] -> Set.Set SrcSpanD
+visibleTypeAppHeads decls =
+    Set.fromList $ exprHeads ++ patHeads
+  where
+    exprHeads =
+        [ SrcSpanD $ locA $ getLoc name
+        | expr <- universeBi decls :: [LHsExpr GhcPs]
+        , L _ (HsAppType _ fun _) <- [expr]
+        , Just name <- [typeAppHead fun]
+        ]
+    patHeads =
+        [ SrcSpanD $ locA $ getLoc name
+        | pat <- universeBi decls :: [LPat GhcPs]
+        , L _ (ConPat _ name details) <- [pat]
+        , hasTypeApp details
+        ]
+    hasTypeApp (PrefixCon tyArgs _) = not $ null tyArgs
+    hasTypeApp _ = False
+
+typeAppHead :: LHsExpr GhcPs -> Maybe (LocatedN RdrName)
+typeAppHead (L _ (HsVar _ name)) = Just name
+typeAppHead (L _ (HsApp _ fun _)) = typeAppHead fun
+typeAppHead (L _ (HsAppType _ fun _)) = typeAppHead fun
+typeAppHead (L _ (HsPar _ fun)) = typeAppHead fun
+typeAppHead _ = Nothing
 
 -- Returns Just iff there are rules for x, which are either unqualified, or qualified with a module that is
 -- one of x's possible modules.
@@ -288,7 +345,7 @@ findFunction
     :: Map.Map String RestrictFunction
     -> LocatedN RdrName
     -> [ModuleName]
-    -> Maybe ([(String, String)], Maybe String)
+    -> Maybe RestrictFunctionItem
 findFunction restrictMap (rdrNameStr -> x) (map moduleNameString -> possMods) = do
     (RestrictFun mp) <- Map.lookup x restrictMap
     n <- NonEmpty.nonEmpty . Map.elems $ Map.filterWithKey (const . maybe True (`elem` possMods)) mp

tests/type_applications.test

@@ -0,0 +1,65 @@
+---------------------------------------------------------------------
+RUN tests/typeAppsRequired.hs --hint=data/type_applications.yaml --only="Use visible type application"
+FILE tests/typeAppsRequired.hs
+{-# LANGUAGE TypeApplications #-}
+module TypeAppsRequired where
+
+a = fromIntegral (1 :: Int)
+b = fromIntegral @Int @Integer (1 :: Int)
+OUTPUT
+tests/typeAppsRequired.hs:4:5-16: Warning: Use visible type application
+Found:
+  fromIntegral
+Note: may break the code
+
+1 hint
+
+---------------------------------------------------------------------
+RUN tests/typeAppsRequiredPattern.hs --hint=data/type_applications.yaml --only="Use visible type application"
+FILE tests/typeAppsRequiredPattern.hs
+{-# LANGUAGE TypeApplications #-}
+module TypeAppsRequiredPattern where
+
+f (Just x) = x
+g (Just @Int x) = x
+OUTPUT
+tests/typeAppsRequiredPattern.hs:4:4-7: Warning: Use visible type application
+Found:
+  Just
+Note: may break the code
+
+1 hint
+
+---------------------------------------------------------------------
+RUN tests/typeAppsForbiddenPattern.hs --hint=data/type_applications.yaml --only="Avoid visible type application"
+FILE tests/typeAppsForbiddenPattern.hs
+{-# LANGUAGE TypeApplications #-}
+module TypeAppsForbiddenPattern where
+
+f (Left @Int x) = x
+g (Left x) = x
+OUTPUT
+tests/typeAppsForbiddenPattern.hs:4:4-7: Warning: Avoid visible type application
+Found:
+  Left
+Note: may break the code
+
+1 hint
+
+---------------------------------------------------------------------
+RUN tests/typeAppsForbidden.hs --hint=data/type_applications.yaml --only="Avoid visible type application"
+FILE tests/typeAppsForbidden.hs
+{-# LANGUAGE TypeApplications #-}
+module TypeAppsForbidden where
+
+a x = id @Int x
+b x = id x
+OUTPUT
+tests/typeAppsForbidden.hs:4:7-8: Warning: Avoid visible type application
+Found:
+  id
+Note: may break the code
+
+1 hint
+
+---------------------------------------------------------------------