{-# LANGUAGE RecordWildCards #-}
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"]
noGeneralizedNewtypeDeriving =
delete "Enum" deriveHaskell ++
deriveGenerics
noDeriveAnyClass = 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") =
any (`notElem` noDeriveAnyClass) .
(\Derives{..} -> derivesNewType ++ derivesData) . 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 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"]
used DeriveGeneric = hasDerive ["Generic","Generic1"]
used GeneralizedNewtypeDeriving =
any (`notElem` noGeneralizedNewtypeDeriving) .
(\Derives{..} -> derivesNewType ++ derivesStandalone) . 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 m = any (`elem` want) $ derivesNewType ++ derivesData ++ derivesStandalone
where Derives{..} = derives m
data Derives = Derives
{derivesNewType :: [String]
,derivesData :: [String]
,derivesStandalone :: [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 = (<>)
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 _ _ _ hd) = mempty{derivesStandalone=[ir hd]}
decl _ = mempty
g dn ds = if isNewType dn then mempty{derivesNewType=xs} else mempty{derivesData=xs}
where xs = concatMap (map ir . fromDeriving) 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