{-# LANGUAGE ScopedTypeVariables #-}
module Hint.Extensions(extensionsHint) where
import Hint.Type
import Control.Monad.Extra
import Data.Maybe
import Data.List.Extra
import Data.Ratio
import Data.Data
import Refact.Types
import Data.Semigroup
import Prelude
extensionsHint :: ModuHint
extensionsHint _ x = [rawIdea Warning "Unused LANGUAGE pragma" (srcInfoSpan sl)
(prettyPrint o) (Just newPragma)
(warnings old new) [refact]
| not $ used TemplateHaskell x
, o@(LanguagePragma sl exts) <- modulePragmas x
, let old = map (parseExtension . prettyPrint) exts
, let new = minimalExtensions x old
, let newPragma = if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) new
, let refact = ModifyComment (toSS o) newPragma
, sort new /= sort old]
minimalExtensions :: Module_ -> [Extension] -> [Extension]
minimalExtensions x es = nubOrd $ concatMap f es
where f e = [e | usedExt e x]
warnings old new | wildcards `elem` old && wildcards `notElem` new = [RequiresExtension "DisambiguateRecordFields"]
where wildcards = EnableExtension RecordWildCards
warnings _ _ = []
deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"]
deriveGenerics = ["Data","Typeable","Generic","Generic1","Lift"]
deriveCategory = ["Functor","Foldable","Traversable"]
noDeriveNewtype =
delete "Enum" deriveHaskell ++
deriveGenerics
deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory
usedExt :: Extension -> Module_ -> Bool
usedExt (EnableExtension x) = used x
usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac
usedExt (UnknownExtension "DeriveLift") = hasDerive ["Lift"]
usedExt (UnknownExtension "DeriveAnyClass") = not . null . derivesAnyclass . derives
usedExt _ = const True
used :: KnownExtension -> Module_ -> Bool
used RecursiveDo = hasS isMDo ||^ hasS isRecStmt
used ParallelListComp = hasS isParComp
used FunctionalDependencies = hasT (un :: FunDep S)
used ImplicitParams = hasT (un :: IPName S)
used TypeApplications = hasS isTypeApp
used EmptyDataDecls = hasS f
where f (DataDecl _ _ _ _ [] _) = True
f (GDataDecl _ _ _ _ _ [] _) = True
f _ = False
used EmptyCase = hasS f
where f (Case _ _ []) = True
f (LCase _ []) = True
f (_ :: Exp_) = False
used KindSignatures = hasT (un :: Kind S)
used BangPatterns = hasS isPBangPat
used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) ||^ hasS f ||^ hasS isSpliceDecl
where f VarQuote{} = True
f TypQuote{} = True
f _ = False
used ForeignFunctionInterface = hasT (un :: CallConv S)
used PatternGuards = hasS f
where f (GuardedRhs _ xs _) = g xs
g [] = False
g [Qualifier{}] = False
g _ = True
used StandaloneDeriving = hasS isDerivDecl
used PatternSignatures = hasS isPatTypeSig
used RecordWildCards = hasS isPFieldWildcard ||^ hasS isFieldWildcard
used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun
used UnboxedTuples = has (not . isBoxed)
used PackageImports = hasS (isJust . importPkg)
used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote
used ViewPatterns = hasS isPViewPat
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 LambdaCase = hasS isLCase
used TupleSections = hasS isTupleSection
used OverloadedStrings = hasS isString
used Arrows = hasS f
where f Proc{} = True
f LeftArrApp{} = True
f RightArrApp{} = True
f LeftArrHighApp{} = True
f RightArrHighApp{} = True
f _ = False
used TransformListComp = hasS f
where f QualStmt{} = False
f _ = True
used MagicHash = hasS f ||^ hasS isPrimLiteral
where f (Ident _ s) = "#" `isSuffixOf` s
f _ = False
used x = usedExt $ UnknownExtension $ show x
hasDerive :: [String] -> Module_ -> 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 (DataOrNew S) -> Maybe (DerivStrategy S) -> [String] -> Derives
addDerives _ (Just s) xs = case s of
DerivStock{} -> mempty{derivesStock = xs}
DerivAnyclass{} -> mempty{derivesAnyclass = xs}
DerivNewtype{} -> mempty{derivesNewtype = xs}
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 :: Module_ -> Derives
derives m = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)
where
idecl :: InstDecl S -> Derives
idecl (InsData _ dn _ _ ds) = g dn ds
idecl (InsGData _ dn _ _ _ ds) = g dn ds
idecl _ = mempty
decl :: Decl_ -> Derives
decl (DataDecl _ dn _ _ _ ds) = g dn ds
decl (GDataDecl _ dn _ _ _ _ ds) = g dn ds
decl (DataInsDecl _ dn _ _ ds) = g dn ds
decl (GDataInsDecl _ dn _ _ _ ds) = g dn ds
decl (DerivDecl _ strategy _ hd) = addDerives Nothing strategy [ir hd]
decl _ = mempty
g dn ds = mconcat [addDerives (Just dn) strategy $ map ir rules | Deriving _ strategy rules <- ds]
ir (IRule _ _ _ x) = ih x
ir (IParen _ x) = ir x
ih (IHCon _ a) = prettyPrint $ unqual a
ih (IHInfix _ _ a) = prettyPrint $ unqual a
ih (IHParen _ a) = ih a
ih (IHApp _ a _) = ih a
un = undefined
hasT t x = not $ null (universeBi x `asTypeOf` [t])
hasT2 ~(t1,t2) = hasT t1 ||^ hasT t2
hasS :: (Data x, Data (f S)) => (f S -> Bool) -> x -> Bool
hasS test = any test . universeBi
has f = any f . universeBi
isWholeFrac :: Literal S -> Bool
isWholeFrac (Frac _ v _) = denominator v == 1
isWholeFrac _ = False