{-# LANGUAGE LambdaCase, NamedFieldPuns #-}
module Hint.Extensions(extensionsHint) where
import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule)
import Extension
import Data.Generics.Uniplate.Operations
import Control.Monad.Extra
import Data.Char
import Data.Maybe
import Data.List.Extra
import Data.Data
import Refact.Types
import qualified Data.Set as Set
import qualified Data.Map as Map
import SrcLoc
import GHC.Hs
import BasicTypes
import Class
import RdrName
import OccName
import ForeignCall
import GHC.Util
import GHC.LanguageExtensions.Type
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.Types
import Language.Haskell.GhclibParserEx.GHC.Hs.Decls
import Language.Haskell.GhclibParserEx.GHC.Driver.Session
extensionsHint :: ModuHint
extensionsHint _ x =
[ rawIdea' Hint.Type.Warning "Unused LANGUAGE pragma"
sl
(comment (mkLanguagePragmas sl exts))
(Just newPragma)
( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++
[ Note $ "Extension " ++ show x ++ " is " ++ reason x
| (_, Just x) <- explainedRemovals])
[ModifyComment (toSS' (mkLanguagePragmas sl exts)) newPragma]
| (L sl _, exts) <- languagePragmas $ pragmas (ghcAnnotations x)
, let before = [(x, readExtension x) | x <- filterEnabled exts]
, let after = filter (maybe True (`Set.member` keep) . snd) before
, before /= after
, let explainedRemovals
| null after && not (any (`Map.member` implied) $ mapMaybe snd before) = []
| otherwise = before \\ after
, let newPragma =
if null after then "" else comment (mkLanguagePragmas sl $ map fst after)
]
where
filterEnabled :: [String] -> [String]
filterEnabled = filter (not . isPrefixOf "No")
usedTH :: Bool
usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x)
extensions :: Set.Set Extension
extensions = Set.fromList $ mapMaybe readExtension $
concatMap (filterEnabled . snd) $ languagePragmas (pragmas (ghcAnnotations x))
useful :: Set.Set Extension
useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions
implied :: Map.Map Extension Extension
implied = Map.fromList
[ (e, a)
| e <- Set.toList useful
, a:_ <- [filter (`Set.member` useful) $ extensionImpliedEnabledBy e]
]
keep :: Set.Set Extension
keep = useful `Set.difference` Map.keysSet implied
disappear :: Map.Map Extension [Extension]
disappear =
Map.fromListWith (++) $
nubOrdOn snd
[ (e, [a])
| e <- Set.toList $ extensions `Set.difference` keep
, a <- fst $ extensionImplies e
, a `Set.notMember` useful
, usedTH || usedExt a (ghcModule x)
]
reason :: Extension -> String
reason x =
case Map.lookup x implied of
Just a -> "implied by " ++ show a
Nothing -> "not used"
deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"]
deriveGenerics = ["Data","Typeable","Generic","Generic1","Lift"]
deriveCategory = ["Functor","Foldable","Traversable"]
noDeriveNewtype =
delete "Enum" deriveHaskell ++
deriveGenerics
deriveStock :: [String]
deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory
usedExt :: Extension -> Located (HsModule GhcPs) -> Bool
usedExt NumDecimals = hasS isWholeFrac
usedExt DeriveLift = hasDerive ["Lift"]
usedExt DeriveAnyClass = not . null . derivesAnyclass . derives
usedExt x = used x
used :: Extension -> Located (HsModule GhcPs) -> Bool
used RecursiveDo = hasS isMDo ||^ hasS isRecStmt
used ParallelListComp = hasS isParComp
used FunctionalDependencies = hasT (un :: FunDep (Located RdrName))
used ImplicitParams = hasT (un :: HsIPName)
used TypeApplications = hasS isTypeApp
used EmptyDataDecls = hasS f
where
f :: HsDataDefn GhcPs -> Bool
f (HsDataDefn _ _ _ _ _ [] _) = True
f _ = False
used EmptyCase = hasS f
where
f :: HsExpr GhcPs -> Bool
f (HsCase _ _ (MG _ (L _ []) _)) = True
f (HsLamCase _ (MG _ (L _ []) _)) = True
f _ = False
used KindSignatures = hasT (un :: HsKind GhcPs)
used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch
used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl
where
f :: HsBracket GhcPs -> Bool
f VarBr{} = True
f TypBr{} = True
f _ = False
used ForeignFunctionInterface = hasT (un :: CCallConv)
used PatternGuards = hasS f
where
f :: GRHS GhcPs (LHsExpr GhcPs) -> Bool
f (GRHS _ xs _) = g xs
f _ = False
g :: [GuardLStmt GhcPs] -> Bool
g [] = False
g [L _ BodyStmt{}] = False
g _ = True
used StandaloneDeriving = hasS isDerivD
used TypeOperators = hasS tyOpInSig ||^ hasS tyOpInDecl
where
tyOpInSig :: HsType GhcPs -> Bool
tyOpInSig = \case
HsOpTy{} -> True; _ -> False
tyOpInDecl :: HsDecl GhcPs -> Bool
tyOpInDecl = \case
(TyClD _ (FamDecl _ FamilyDecl{fdLName})) -> isOp fdLName
(TyClD _ SynDecl{tcdLName}) -> isOp tcdLName
(TyClD _ DataDecl{tcdLName}) -> isOp tcdLName
(TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs])
_ -> False
isOp :: LIdP GhcPs -> Bool
isOp name = case occNameString (rdrNameOcc (unLoc name)) of
(c:_) -> not $ isAlpha c || c == '_'
_ -> False
used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot
used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate
used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving
where
isDeriving :: Maybe (LDerivStrategy GhcPs) -> Bool
isDeriving _ = True
used PackageImports = hasS f
where
f :: ImportDecl GhcPs -> Bool
f ImportDecl{ideclPkgQual=Just _} = True
f _ = False
used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote
used ViewPatterns = hasS isPViewPat
used InstanceSigs = hasS f
where
f :: HsDecl GhcPs -> Bool
f (InstD _ decl) = hasT (un :: Sig GhcPs) decl
f _ = False
used DefaultSignatures = hasS isClsDefSig
used DeriveDataTypeable = hasDerive ["Data","Typeable"]
used DeriveFunctor = hasDerive ["Functor"]
used DeriveFoldable = hasDerive ["Foldable"]
used DeriveTraversable = hasDerive ["Traversable","Foldable","Functor"]
used DeriveGeneric = hasDerive ["Generic","Generic1"]
used GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives
used MultiWayIf = hasS isMultiIf
used LambdaCase = hasS isLCase
used TupleSections = hasS isTupleSection
used OverloadedStrings = hasS isString
used Arrows = hasS isProc
used TransformListComp = hasS isTransStmt
used MagicHash = hasS f ||^ hasS isPrimLiteral
where
f :: RdrName -> Bool
f s = "#" `isSuffixOf` (occNameString . rdrNameOcc) s
used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE
where
isPatSynBind :: HsBind GhcPs -> Bool
isPatSynBind PatSynBind{} = True
isPatSynBind _ = False
isPatSynIE :: IEWrappedName RdrName -> Bool
isPatSynIE IEPattern{} = True
isPatSynIE _ = False
used _= const True
hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool
hasDerive want = any (`elem` want) . derivesStock' . derives
data Derives = Derives
{derivesStock' :: [String]
,derivesAnyclass :: [String]
,derivesNewtype' :: [String]
}
instance Semigroup Derives where
Derives x1 x2 x3 <> Derives y1 y2 y3 =
Derives (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
instance Monoid Derives where
mempty = Derives [] [] []
mappend = (<>)
addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives
addDerives _ (Just s) xs = case s of
StockStrategy -> mempty{derivesStock' = xs}
AnyclassStrategy -> mempty{derivesAnyclass = xs}
NewtypeStrategy -> mempty{derivesNewtype' = xs}
ViaStrategy{} -> mempty
addDerives nt _ xs = mempty
{derivesStock' = stock
,derivesAnyclass = other
,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []}
where (stock, other) = partition (`elem` deriveStock) xs
derives :: Located (HsModule GhcPs) -> Derives
derives (L _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)
where
idecl :: Located (DataFamInstDecl GhcPs) -> Derives
idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds
idecl _ = mempty
decl :: LHsDecl GhcPs -> Derives
decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds
decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig]
decl _ = mempty
g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives
g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds]
derivedToStr :: LHsSigType GhcPs -> String
derivedToStr (HsIB _ t) = ih t
where
ih :: LHsType GhcPs -> String
ih (L _ (HsQualTy _ _ a)) = ih a
ih (L _ (HsParTy _ a)) = ih a
ih (L _ (HsAppTy _ a _)) = ih a
ih (L _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual' a
ih (L _ a) = unsafePrettyPrint a
derivedToStr _ = ""
un = undefined
hasT t x = not $ null (universeBi x `asTypeOf` [t])
hasT2' ~(t1,t2) = hasT t1 ||^ hasT t2
hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool
hasS test = any test . universeBi