packages feed

hlint 2.2 → 2.2.1

raw patch · 29 files changed

+656/−283 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Language.Haskell.HLint4: createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx

Files

CHANGES.txt view
@@ -1,5 +1,10 @@ Changelog for HLint (* = breaking change) +2.2.1, released 2019-07-22+    #713, make sure -XNoPatternSynonyms works (fix regression)+    #700, add some Monoid and Alternative hints+    Add createModuleEx to the API+    #698, don't suggest a replacement for DerivingStrategies 2.2, released 2019-06-26 *   Remove functions and make some things abstract in HLint3 API 2.1.26, released 2019-06-26
data/hlint.yaml view
@@ -210,6 +210,15 @@     - warn: {lhs: zipWith f (repeat x), rhs: map (f x)}     - warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y} +    # MONOIDS++    - warn: {lhs: mempty <> x, rhs: x, name: "Monoid law, left identity"}+    - warn: {lhs: mempty `mappend` x, rhs: x, name: "Monoid law, left identity"}+    - warn: {lhs: x <> mempty, rhs: x, name: "Monoid law, right identity"}+    - warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"}+    - warn: {lhs: foldr (<>) mempty, rhs: mconcat}+    - warn: {lhs: foldr mappend mempty, rhs: mconcat}+     # TRAVERSABLES      - warn: {lhs: sequenceA (map f x), rhs: traverse f x}@@ -441,6 +450,8 @@     - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}     - hint: {lhs: m >>= pure . f, rhs: f <$> m}     - hint: {lhs: pure . f =<< m, rhs: f <$> m}+    - warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"}+    - warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}       # LIST COMP
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.2+version:            2.2.1 license:            BSD3 license-file:       LICENSE category:           Development
src/Apply.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-}  module Apply(applyHints, applyHintFile, applyHintFiles) where @@ -5,6 +6,7 @@ import Data.Monoid import HSE.All import Hint.All+import GHC.Util import Idea import Data.Tuple.Extra import Data.Either@@ -13,6 +15,8 @@ import Data.Ord import Config.Type import Config.Haskell+import "ghc-lib-parser" HsSyn+import qualified "ghc-lib-parser" SrcLoc as GHC import qualified Data.HashSet as Set import Prelude @@ -40,26 +44,27 @@ --   When given multiple modules at once this function attempts to find hints between modules, --   which is slower and often pointless (by default HLint passes modules singularly, using --   @--cross@ to pass all modules together).-applyHints {- PUBLIC -} :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea]+applyHints {- PUBLIC -} :: [Classify] -> Hint -> [ModuleEx] -> [Idea] applyHints cs = applyHintsReal $ map SettingClassify cs -applyHintsReal :: [Setting] -> Hint -> [(Module_, [Comment])] -> [Idea]+applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] applyHintsReal settings hints_ ms = concat $-    [ map (classify classifiers . removeRequiresExtensionNotes m) $+    [ map (classify classifiers . removeRequiresExtensionNotes (hseModule m)) $         order [] (hintModule hints settings nm m) `merge`-        concat [order [fromNamed d] $ decHints d | d <- moduleDecls m] `merge`-        concat [order [] $ hintComment hints settings c | c <- cs]-    | (nm,(m,cs)) <- mns-    , let classifiers = cls ++ mapMaybe readPragma (universeBi m) ++ concatMap readComment cs+        concat [order [fromNamed d] $ decHints d | d <- moduleDecls (hseModule m)] `merge`+        concat [order [declName $ GHC.unLoc d] $ decHints' d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]+    | (nm, m) <- mns+    , let classifiers = cls ++ mapMaybe readPragma (universeBi (hseModule m)) ++ concatMap readComment (ghcComments m)     , seq (length classifiers) True -- to force any errors from readPragma or readComment     , let decHints = hintDecl hints settings nm m -- partially apply-    , let order n = map (\i -> i{ideaModule= f $ moduleName m : ideaModule i, ideaDecl= f $ n ++ ideaDecl i}) . sortOn ideaSpan+    , let decHints' = hintDecl' hints settings nm m -- partially apply+    , let order n = map (\i -> i{ideaModule= f $ moduleName (hseModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn ideaSpan     , let merge = mergeBy (comparing ideaSpan)] ++-    [map (classify cls) (hintModules hints settings $ map (second fst) mns)]+    [map (classify cls) (hintModules hints settings mns)]     where         f = nubOrd . filter (/= "")         cls = [x | SettingClassify x <- settings]-        mns = map (scopeCreate . fst &&& id) ms+        mns = map (\x -> (scopeCreate (hseModule x), x)) ms         hints = (if length ms <= 1 then noModules else id) hints_         noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]} @@ -72,17 +77,17 @@         keep _ = True  -- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules.-executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea]+executeHints :: [Setting] -> [ModuleEx] -> [Idea] executeHints s = applyHintsReal s (allHints s)   -- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor.-parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea (Module_, [Comment]))+parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea ModuleEx) parseModuleApply flags s file src = do     res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src     case res of-        Right (ModuleEx (m, c) _)  -> return $ Right (m,c)-        Left (ParseError sl msg ctxt) ->+      Right r -> return $ Right r+      Left (ParseError sl msg ctxt) ->             return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []
src/Config/Compute.hs view
@@ -18,7 +18,7 @@     case x of         Left (ParseError sl msg _) ->             return ("# Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        Right (ModuleEx (m, _) _) -> do+        Right (ModuleEx m _ _ _) -> do             let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)                 r = concatMap (readSetting mempty) xs                 s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting r ++ ["# no hints found" | null xs]
src/Config/Haskell.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-}-+{-# LANGUAGE PackageImports #-} module Config.Haskell(     readPragma,     readComment,@@ -16,6 +16,9 @@ import Config.Type import Util import Prelude+import GHC.Util+import "ghc-lib-parser" SrcLoc as GHC+import "ghc-lib-parser" ApiAnnotation   addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]@@ -31,7 +34,7 @@     case res of         Left (ParseError sl msg err) ->             error $ "Config parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err-        Right (ModuleEx (m, cs) _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment cs)+        Right modEx@(ModuleEx m _ _ _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment (ghcComments modEx))   -- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.@@ -78,22 +81,23 @@         f _ _ = Nothing  -readComment :: Comment -> [Classify]-readComment o@(Comment True _ x)+readComment :: GHC.Located AnnotationComment -> [Classify]+readComment c@(L pos AnnBlockComment{})     | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x     , x <- trim x     , (hlint, x) <- word1 x     , lower hlint == "hlint"     = f hash x     where+        x = commentText c         f hash x             | Just x <- if hash then stripSuffix "#" x else Just x             , (sev, x) <- word1 x             , Just sev <- getSeverity sev             , (things, x) <- g x-            , Just (hint :: String) <- if x == "" then Just "" else readMaybe x+            , Just hint <- if x == "" then Just "" else readMaybe x             = map (Classify sev hint "") $ ["" | null things] ++ things-        f hash _ = errorOnComment o $ "bad HLINT pragma, expected:\n    {-" ++ h ++ " HLINT <severity> <identifier> \"Hint name\" " ++ h ++ "-}"+        f hash _ = errorOnComment c $ "bad HLINT pragma, expected:\n    {-" ++ h ++ " HLINT <severity> <identifier> \"Hint name\" " ++ h ++ "-}"             where h = ['#' | hash]          g x | (s, x) <- word1 x@@ -155,8 +159,9 @@     ": Error while reading hint file, " ++ msg ++ "\n" ++     prettyPrint val -errorOnComment :: Comment -> String -> b-errorOnComment (Comment b ann x) msg = exitMessageImpure $-    showSrcLoc (getPointLoc ann) +++errorOnComment :: GHC.Located AnnotationComment -> String -> b+errorOnComment c@(L s _) msg = exitMessageImpure $+    let isMultiline = isCommentMultiline c in+    showSrcLoc (ghcSrcLocToHSE $ GHC.srcSpanStart s) ++     ": Error while reading hint file, " ++ msg ++ "\n" ++-    (if b then "{-" else "--") ++ x ++ (if b then "-}" else "")+    (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
src/Config/Yaml.hs view
@@ -159,8 +159,8 @@ parseConfigYaml :: Val -> Parser ConfigYaml parseConfigYaml v = do     vs <- parseArray v-    fmap ConfigYaml $ forM vs $ \o@v -> do-        (s, v) <- parseObject1 v+    fmap ConfigYaml $ forM vs $ \o -> do+        (s, v) <- parseObject1 o         case s of             "package" -> ConfigPackage <$> parsePackage v             "group" -> ConfigGroup <$> parseGroup v
src/GHC/Util.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}  module GHC.Util (@@ -12,6 +12,12 @@   , SDoc   , Located   , readExtension+  , commentText, isCommentMultiline+  , declName+  , unsafePrettyPrint+  , eqMaybe+  , noloc, unloc, getloc, noext+  , isForD   -- Temporary : Export these so GHC doesn't consider them unused and   -- tell weeder to ignore them.   , isAtom, addParen, paren, isApp, isOpApp, isAnyApp, isDot, isSection, isDotApp@@ -27,6 +33,7 @@ import "ghc-lib-parser" Lexer import "ghc-lib-parser" Parser import "ghc-lib-parser" SrcLoc+import "ghc-lib-parser" OccName import "ghc-lib-parser" FastString import "ghc-lib-parser" StringBuffer import "ghc-lib-parser" ErrUtils@@ -35,8 +42,9 @@ import "ghc-lib-parser" Panic import "ghc-lib-parser" HscTypes import "ghc-lib-parser" HeaderInfo+import "ghc-lib-parser" ApiAnnotation -import Data.List+import Data.List.Extra import System.FilePath import Language.Preprocessor.Unlit import qualified Data.Map.Strict as Map@@ -60,25 +68,18 @@ fakeLlvmConfig :: (LlvmTargets, LlvmPasses) fakeLlvmConfig = ([], []) -badExtensions :: [Extension]-badExtensions =-  [-    AlternativeLayoutRule-  , AlternativeLayoutRuleTransitional-  , Arrows-  , TransformListComp-  , UnboxedTuples-  , UnboxedSums-  , QuasiQuotes-  , RecursiveDo- ]--enabledExtensions :: [Extension]-enabledExtensions = filter (`notElem` badExtensions) enumerateExtensions- baseDynFlags :: DynFlags-baseDynFlags = foldl' xopt_set-             (defaultDynFlags fakeSettings fakeLlvmConfig) enabledExtensions+baseDynFlags =+  -- The list of default enabled extensions is empty except for+  -- 'TemplateHaskellQuotes'. This is because:+  --  * The extensions to enable/disable are set exclusively in+  --    'parsePragmasIntoDynFlags' based solely on HSE parse flags+  --    (and source level annotations);+  --  * 'TemplateHaskellQuotes' is not a known HSE extension but IS+  --    needed if the GHC parse is to succeed for the unit-test at+  --    hlint.yaml:860+  let enable = [TemplateHaskellQuotes]+  in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable  -- | Adjust the input 'DynFlags' to take into account language -- extensions to explicitly enable/disable as well as language@@ -94,7 +95,8 @@     (flags, _, _) <- parseDynamicFilePragma flags opts     let flags' =  foldl' xopt_set flags enable     let flags'' = foldl' xopt_unset flags' disable-    return $ Right flags''+    let flags''' = flags'' `gopt_set` Opt_KeepRawTokenStream+    return $ Right flags'''   where     catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)     catchErrors act = handleGhcException reportErr@@ -118,7 +120,7 @@ -- (of which at least one of them came from this project originally).  -- | 'isAtom e' if 'e' requires no bracketing ever.-isAtom :: (p ~ GhcPass pass) => HsExpr p -> Bool+isAtom :: HsExpr GhcPs -> Bool isAtom x = case x of   HsVar {}          -> True   HsUnboundVar {}   -> True@@ -156,30 +158,30 @@     isNegativeOverLit _ = False  -- | 'addParen e' wraps 'e' in parens.-addParen :: (p ~ GhcPass pass) => HsExpr p -> HsExpr p+addParen :: HsExpr GhcPs -> HsExpr GhcPs addParen e = HsPar noExt (noLoc e)  -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.-paren :: (p ~ GhcPass pass) => HsExpr GhcPs -> HsExpr GhcPs+paren :: HsExpr GhcPs -> HsExpr GhcPs paren x   | isAtom x  = x   | otherwise = addParen x  -- | 'isApp e' if 'e' is a (regular) application.-isApp :: (p ~ GhcPass pass) => HsExpr p -> Bool+isApp :: HsExpr GhcPs -> Bool isApp x = case x of   HsApp {}  -> True   _         -> False  -- | 'isOpApp e' if 'e' is an operator application.-isOpApp :: (p ~ GhcPass pass) => HsExpr p -> Bool+isOpApp :: HsExpr GhcPs -> Bool isOpApp x = case x of   OpApp {}   -> True   _          -> False  -- | 'isAnyApp e' if 'e' is either an application or operator -- application.-isAnyApp :: (p ~ GhcPass pass) => HsExpr p -> Bool+isAnyApp :: HsExpr GhcPs -> Bool isAnyApp x = isApp x || isOpApp x  -- | 'isDot e'  if 'e' is the unqualifed variable '.'.@@ -190,27 +192,99 @@   | otherwise                          = False  -- | 'isSection e' if 'e' is a section.-isSection :: (p ~ GhcPass pass) => HsExpr p -> Bool+isSection :: HsExpr GhcPs -> Bool isSection x = case x of   SectionL {} -> True   SectionR {} -> True   _           -> False +-- | 'isForD d' if 'd' is a foreign declaration.+isForD :: HsDecl GhcPs -> Bool+isForD ForD{} = True+isForD _ = False+ -- | 'isDotApp e' if 'e' is dot application. isDotApp :: HsExpr GhcPs -> Bool isDotApp (OpApp _ _ (L _ op) _) = isDot op isDotApp _ = False --- | All available GHC extensions-enumerateExtensions :: [Extension]--- 'Cpp' are the first and last cases of type 'Extension' in--- 'libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs'. When we are--- on a version of GHC that has MR--- https://gitlab.haskell.org/ghc/ghc/merge_requests/826, we can--- replace them with 'minBound' and 'maxBound' respectively.-enumerateExtensions = [Cpp .. StarIsType]- -- | Parse a GHC extension readExtension :: String -> Maybe Extension readExtension x = Map.lookup x exts   where exts = Map.fromList [(show x, x) | x <- [Cpp .. StarIsType]]++trimCommentStart :: String -> String+trimCommentStart s+    | Just s <- stripPrefix "{-" s = s+    | Just s <- stripPrefix "--" s = s+    | otherwise = s++trimCommentEnd :: String -> String+trimCommentEnd s+    | Just s <- stripSuffix "-}" s = s+    | otherwise = s++trimCommentDelims :: String -> String+trimCommentDelims = trimCommentEnd . trimCommentStart++-- | Access to a comment's text.+commentText :: Located AnnotationComment -> String+commentText (L _ (AnnDocCommentNext s)) = trimCommentDelims s+commentText (L _ (AnnDocCommentPrev s)) = trimCommentDelims s+commentText (L _ (AnnDocCommentNamed s)) = trimCommentDelims s+commentText (L _ (AnnDocSection _ s)) = trimCommentDelims s+commentText (L _ (AnnDocOptions s)) = trimCommentDelims s+commentText (L _ (AnnLineComment s)) = trimCommentDelims s+commentText (L _ (AnnBlockComment s)) = trimCommentDelims s++isCommentMultiline :: Located AnnotationComment -> Bool+isCommentMultiline (L _ (AnnBlockComment _)) = True+isCommentMultiline _ = False++declName :: HsDecl GhcPs -> String+declName (TyClD _ FamDecl{tcdFam=FamilyDecl{fdLName}}) = occNameString $ occName $ unLoc fdLName+declName (TyClD _ SynDecl{tcdLName}) = occNameString $ occName $ unLoc tcdLName+declName (TyClD _ DataDecl{tcdLName}) = occNameString $ occName $ unLoc tcdLName+declName (TyClD _ ClassDecl{tcdLName}) = occNameString $ occName $ unLoc tcdLName+declName (ValD _ FunBind{fun_id})  = occNameString $ occName $ unLoc fun_id+declName (ValD _ VarBind{var_id})  = occNameString $ occName var_id+declName (ValD _ (PatSynBind _ PSB{psb_id})) = occNameString $ occName $ unLoc psb_id+declName (SigD _ (TypeSig _ (x:_) _)) = occNameString $ occName $ unLoc x+declName (SigD _ (PatSynSig _ (x:_) _)) = occNameString $ occName $ unLoc x+declName (SigD _ (ClassOpSig _ _ (x:_) _)) = occNameString $ occName $ unLoc x+declName (ForD _ ForeignImport{fd_name}) = occNameString $ occName $ unLoc fd_name+declName (ForD _ ForeignExport{fd_name}) = occNameString $ occName $ unLoc fd_name+declName _ = ""++-- \"Unsafely\" in this case means that it uses the following+-- 'DynFlags' for printing -+-- <http://hackage.haskell.org/package/ghc-lib-parser-8.8.0.20190424/docs/src/DynFlags.html#v_unsafeGlobalDynFlags+-- unsafeGlobalDynFlags> This could lead to the issues documented+-- there, but it also might not be a problem for our use case.  TODO:+-- Decide whether this really is unsafe, and if it is, what needs to+-- be done to make it safe.+unsafePrettyPrint :: (Outputable.Outputable a) => a -> String+unsafePrettyPrint = Outputable.showSDocUnsafe . Outputable.ppr++-- | Test if two AST elements are equal modulo annotations.+(=~=) :: Eq a => Located a -> Located a -> Bool+a =~= b = unLoc a == unLoc b++-- | Compare two 'Maybe (Located a)' values for equality modulo+-- locations.+eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool+eqMaybe (Just x) (Just y) = x =~= y+eqMaybe Nothing Nothing = True+eqMaybe _ _ = False++noloc :: e -> Located e+noloc = noLoc++unloc :: Located e -> e+unloc = unLoc++getloc :: Located e -> SrcSpan+getloc = getLoc++noext :: NoExt+noext = noExt
src/Grep.hs view
@@ -26,6 +26,6 @@         case res of             Left (ParseError sl msg ctxt) ->                 print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []-            Right (ModuleEx (m, c) _) ->-                forM_ (applyHints [] rule [(m, c)]) $ \i ->+            Right m ->+                forM_ (applyHints [] rule [m]) $ \i ->                     print i{ideaHint="", ideaTo=Nothing}
src/HSE/All.hs view
@@ -7,8 +7,9 @@     CppFlags(..), ParseFlags(..), defaultParseFlags,     parseFlagsAddFixities, parseFlagsSetLanguage,     ParseError(..), ModuleEx(..),-    parseModuleEx,-    freeVars, vars, varss, pvars+    parseModuleEx, ghcComments,+    freeVars, vars, varss, pvars,+    ghcSpanToHSE, ghcSrcLocToHSE     ) where  import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))@@ -38,8 +39,32 @@ import qualified "ghc-lib-parser" SrcLoc as GHC import qualified "ghc-lib-parser" ErrUtils import qualified "ghc-lib-parser" Outputable+import qualified "ghc-lib-parser" Lexer as GHC import qualified "ghc-lib-parser" GHC.LanguageExtensions.Type as GHC+import qualified "ghc-lib-parser" ApiAnnotation as GHC +-- | Convert a GHC source loc into an HSE equivalent.+ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc+ghcSrcLocToHSE (GHC.RealSrcLoc l) =+  SrcLoc {+      srcFilename = FastString.unpackFS (GHC.srcLocFile l)+    , srcLine = GHC.srcLocLine l+    , srcColumn = GHC.srcLocCol l+    }+ghcSrcLocToHSE (GHC.UnhelpfulLoc _) = noLoc++-- | Convert a GHC source span into an HSE equivalent.+ghcSpanToHSE :: GHC.SrcSpan -> SrcSpan+ghcSpanToHSE (GHC.RealSrcSpan s) =+  SrcSpan {+      srcSpanFilename = FastString.unpackFS (GHC.srcSpanFile s)+    , srcSpanStartLine = GHC.srcSpanStartLine s+    , srcSpanStartColumn = GHC.srcSpanStartCol s+    , srcSpanEndLine = GHC.srcSpanEndLine s+    , srcSpanEndColumn = GHC.srcSpanEndCol s+    }+ghcSpanToHSE (GHC.UnhelpfulSpan _) = mkSrcSpan noLoc noLoc+ vars :: FreeVars a => a -> [String] freeVars :: FreeVars a => a -> Set String varss, pvars :: AllVars a => a -> [String]@@ -162,14 +187,19 @@  -- | Result of 'parseModuleEx', representing a parsed module. data ModuleEx = ModuleEx {-    -- Combined 'hs-src-ext' and 'ghc-lib-parser' parse trees.-    pm_hsext  :: (Module SrcSpanInfo, [Comment]) -- hs-src-ext result-  , pm_ghclib :: Located (HsSyn.HsModule HsSyn.GhcPs) -- ghc-lib-parser result+    hseModule :: Module SrcSpanInfo+  , hseComments :: [Comment]+  , ghcModule :: Located (HsSyn.HsModule HsSyn.GhcPs)+  , ghcAnnotations :: GHC.ApiAnns } +-- | Extract a list of all of a parsed module's comments.+ghcComments :: ModuleEx -> [Located GHC.AnnotationComment]+ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))+ -- | Utility called from 'parseModuleEx' and 'hseFailOpParseModuleEx'. mkMode :: ParseFlags -> String -> ParseMode-mkMode flags file = (hseFlags flags){parseFilename = file,fixities = Nothing }+mkMode flags file = (hseFlags flags){ parseFilename = file,fixities = Nothing }  -- | Error handler dispatcher. Invoked when HSE parsing has failed. failOpParseModuleEx :: String@@ -262,8 +292,12 @@         case dynFlags of           Right ghcFlags ->             case (parseFileContentsWithComments (mkMode flags file) ppstr, parseFileGhcLib file ppstr ghcFlags) of-                (ParseOk (x, cs), POk _ a) ->-                    return $ Right (ModuleEx (applyFixity fixity x, cs) a)+                (ParseOk (x, cs), POk pst a) ->+                    let anns =+                          ( Map.fromListWith (++) $ GHC.annotations pst+                          , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pst) : GHC.annotations_comments pst)+                          ) in+                    return $ Right (ModuleEx (applyFixity fixity x) cs a anns)                 -- Parse error if GHC parsing fails (see                 -- https://github.com/ndmitchell/hlint/issues/645).                 (ParseOk _, PFailed _ loc err) ->
src/HSE/Util.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ViewPatterns, TupleSections #-}+{-# LANGUAGE FlexibleContexts, TupleSections #-}  module HSE.Util(module HSE.Util, def) where @@ -235,15 +235,6 @@  --------------------------------------------------------------------- -- HSE FUNCTIONS--isKindHash :: Type_ -> Bool-isKindHash (TyParen _ x) = isKindHash x-isKindHash (TyApp _ x _) = isKindHash x-isKindHash (TyCon _ (fromQual -> Just (Ident _ s))) = "#" `isSuffixOf`  s-isKindHash (TyTuple _ Unboxed _) = True-isKindHash TyUnboxedSum{} = True-isKindHash _ = False-  getEquations :: Decl s -> [Decl s] getEquations (FunBind s xs) = map (FunBind s . (:[])) xs
src/Hint/All.hs view
@@ -1,6 +1,6 @@  module Hint.All(-    Hint(..), HintBuiltin(..), DeclHint, ModuHint,+    Hint(..), DeclHint, ModuHint,     resolveHints, hintRules, builtinHints     ) where @@ -49,24 +49,24 @@     HintMonad      -> decl monadHint     HintLambda     -> decl lambdaHint     HintBracket    -> decl bracketHint-    HintNaming     -> decl namingHint+    HintNaming     -> decl' namingHint     HintPattern    -> decl patternHint     HintImport     -> modu importHint     HintExport     -> modu exportHint+    HintComment    -> modu commentHint     HintPragma     -> modu pragmaHint     HintExtensions -> modu extensionsHint     HintUnsafe     -> decl unsafeHint     HintDuplicate  -> mods duplicateHint-    HintComment    -> comm commentHint-    HintNewType    -> decl newtypeHint+    HintNewType    -> decl' newtypeHint     HintRestrict   -> mempty{hintModule=restrictHint}     HintSmell      -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}     where         wrap = timed "Hint" (drop 4 $ show x) . forceList         decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}+        decl' f = mempty{hintDecl'=const $ \a b c -> wrap $ f a b c}         modu f = mempty{hintModule=const $ \a b -> wrap $ f a b}         mods f = mempty{hintModules=const $ \a -> wrap $ f a}-        comm f = mempty{hintComment=const $ \a -> wrap $ f a}  -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)]
src/Hint/Comment.hs view
@@ -10,6 +10,7 @@ <COMMENT> INLINE X </TEST> -}+{-# LANGUAGE PackageImports #-}   module Hint.Comment(commentHint) where@@ -18,21 +19,31 @@ import Data.Char import Data.List.Extra import Refact.Types(Refactoring(ModifyComment))-+import "ghc-lib-parser" SrcLoc+import "ghc-lib-parser" ApiAnnotation+import GHC.Util  pragmas = words $     "LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++     "CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE"  -commentHint :: Comment -> [Idea]-commentHint c@(Comment True span s)-    | "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" c $ '#':s]-    | name `elem` pragmas = [grab "Use pragma syntax" c $ "# " ++ trim s ++ " #"]-        where name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s-commentHint _ = []+commentHint :: ModuHint+commentHint _ m = concatMap chk (ghcComments m)+    where+        chk :: Located AnnotationComment -> [Idea]+        chk comm+          | isMultiline, "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" comm $ '#':s]+          | isMultiline, name `elem` pragmas = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"]+               where+                 isMultiline = isCommentMultiline comm+                 s = commentText comm+                 name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s+        chk _ = [] -grab :: String -> Comment -> String -> Idea-grab msg (Comment typ pos s1) s2 = rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact-    where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s-          refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]+        grab :: String -> Located AnnotationComment -> String -> Idea+        grab msg o@(L pos _) s2 =+          let s1 = commentText o in+          rawIdea Suggestion msg (ghcSpanToHSE pos) (f s1) (Just $ f s2) [] refact+            where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s+                  refact = [ModifyComment (toRefactSrcSpan (ghcSpanToHSE pos)) (f s2)]
src/Hint/Duplicate.hs view
@@ -32,7 +32,7 @@ duplicateHint ms =     dupes [(m,d,y) | (m,d,x) <- ds, Do _ y :: Exp S <- universeBi x] ++     dupes [(m,d,y) | (m,d,x) <- ds, BDecls _ y :: Binds S <- universeBi x]-    where ds = [(moduleName m, fromNamed d, d) | m <- map snd ms, d <- moduleDecls m]+    where ds = [(moduleName (hseModule m), fromNamed d, d) | m <- map snd ms, d <- moduleDecls (hseModule m)]   dupes :: (Pretty (f SrcSpan), Annotated f, Ord (f ())) => [(String, String, [f S])] -> [Idea]
src/Hint/Export.hs view
@@ -9,18 +9,38 @@ module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where </TEST> -}+{-# LANGUAGE PackageImports #-}  module Hint.Export(exportHint) where  import Hint.Type-+import "ghc-lib-parser" HsSyn+import qualified "ghc-lib-parser" Module as GHC+import "ghc-lib-parser" SrcLoc as GHC+import "ghc-lib-parser" OccName+import "ghc-lib-parser" RdrName  exportHint :: ModuHint-exportHint _ (Module _ (Just o@(ModuleHead a name warning exports)) _ _ _)-    | Nothing <- exports =-        let o2 = ModuleHead a name warning $ Just $ ExportSpecList a [EModuleContents a name]-        in [(ignore "Use module export list" o o2 []){ideaNote = [Note "an explicit list is usually better"]}]-    | Just (ExportSpecList _ xs) <- exports, EModuleContents a name `elem_` xs =-        let o2 = ModuleHead a name warning $ Just $ ExportSpecList a $ EVar a ellipses : delete_ (EModuleContents a name) xs-        in [ignore "Use explicit module export list" o o2 []]+exportHint _ (ModuleEx _ _ (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)+  | Nothing <- exports =+      let r = o{ hsmodExports = Just (GHC.noLoc [GHC.noLoc (IEModuleContents noExt name)] )} in+      [(ignore' "Use module export list" (L s o) (GHC.noLoc r) []){ideaNote = [Note "an explicit list is usally better"]}]+  | Just (L _ xs) <- exports+  , mods <- [x | x <- xs, isMod x]+  , modName <- GHC.moduleNameString (GHC.unLoc name)+  , names <- [GHC.moduleNameString (GHC.unLoc n) | (L _ (IEModuleContents _ n)) <- mods]+  , exports' <- [x | x <- xs, not (matchesModName modName x)]+  , modName `elem` names =+      let dots = mkRdrUnqual (mkVarOcc " ... ")+          r = o{ hsmodExports = Just (GHC.noLoc (GHC.noLoc (IEVar noExt (GHC.noLoc (IEName (GHC.noLoc dots)))) : exports') )}+      in+        [ignore' "Use explicit module export list" (L s o) (GHC.noLoc r) []]+      where+          o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }+          isMod (L _ (IEModuleContents _ _)) = True+          isMod _ = False++          matchesModName m (L _ (IEModuleContents _ (L _ n))) = GHC.moduleNameString n == m+          matchesModName _ _ = False+ exportHint _ _ = []
src/Hint/Extensions.hs view
@@ -156,7 +156,7 @@             [ Note $ "Extension " ++ prettyExtension x ++ " is " ++ reason x             | x <- explainedRemovals])         [ModifyComment (toSS o) newPragma]-    | o@(LanguagePragma sl exts) <- modulePragmas x+    | o@(LanguagePragma sl exts) <- modulePragmas (hseModule x)     , let before = map (parseExtension . prettyPrint) exts     , let after = filter (`Set.member` keep) before     , before /= after@@ -166,14 +166,14 @@     , let newPragma = if null after then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) after     ]     where-        usedTH = used TemplateHaskell x || used QuasiQuotes x+        usedTH = used TemplateHaskell (hseModule x) || used QuasiQuotes (hseModule x)             -- if TH or QuasiQuotes is on, can use all other extensions programmatically          -- all the extensions defined to be used-        extensions = Set.fromList [parseExtension $ fromNamed e | LanguagePragma _ exts <- modulePragmas x, e <- exts]+        extensions = Set.fromList [parseExtension $ fromNamed e | LanguagePragma _ exts <- modulePragmas (hseModule x), e <- exts]          -- those extensions we detect to be useful-        useful = if usedTH then extensions  else Set.filter (`usedExt` x) extensions+        useful = if usedTH then extensions  else Set.filter (`usedExt` hseModule x) extensions          -- those extensions which are useful, but implied by other useful extensions         implied = Map.fromList@@ -192,7 +192,7 @@             | e <- Set.toList $ extensions `Set.difference` keep             , a <- extensionImplies e             , a `Set.notMember` useful-            , usedTH || usedExt a x+            , usedTH || usedExt a (hseModule x)             ]          reason x =
src/Hint/Import.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-} {-     Reduce the number of import declarations.@@ -48,61 +49,123 @@ import Data.Maybe import Prelude +import "ghc-lib-parser" FastString+import "ghc-lib-parser" BasicTypes+import "ghc-lib-parser" RdrName+import "ghc-lib-parser" Module+import "ghc-lib-parser" HsSyn as GHC+import qualified "ghc-lib-parser" SrcLoc as GHC+import GHC.Util  importHint :: ModuHint-importHint _ x = concatMap (wrap . snd) (groupSort-                 [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++-                 concatMap (\x -> hierarchy x ++ combine1 x) (universeBi x)---wrap :: [ImportDecl S] -> [Idea]-wrap o = [ rawIdea Warning "Use fewer imports" (srcInfoSpan $ ann $ head o) (f o) (Just $ f x) [] rs-         | Just (x, rs) <- [simplify o]]-    where f = unlines . map prettyPrint+importHint _ ModuleEx {ghcModule=GHC.L _ HsModule{hsmodImports=ms}} =+  -- Ideas for combining multiple imports.+  concatMap (reduceImports . snd) (+    groupSort [((n, pkg), i) | i <- ms+              , not $ ideclSource (unloc i)+              , let i' = unloc i+              , let n = unloc $ ideclName i'+              , let pkg  = unpackFS . sl_fs <$> ideclPkgQual i']) +++  -- Ideas for removing redundant 'as' clauses.+  concatMap stripRedundantAlias ms +++  -- Ideas for replacing deprecated imports by their preferred+  -- equivalents.+  concatMap preferHierarchicalImports ms +reduceImports :: [LImportDecl GhcPs] -> [Idea]+reduceImports ms =+  [rawIdea Hint.Type.Warning "Use fewer imports"+    (ghcSpanToHSE (getloc $ head ms)) (f ms) (Just $ f x) [] rs+  | Just (x, rs) <- [simplify ms]]+  where f = unlines . map unsafePrettyPrint -simplify :: [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])+simplify :: [LImportDecl GhcPs]+         -> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan]) simplify [] = Nothing-simplify (x:xs) = case simplifyHead x xs of+simplify (x : xs) = case simplifyHead x xs of     Nothing -> first (x:) <$> simplify xs     Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs --simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])-simplifyHead x [] = Nothing-simplifyHead x (y:ys) = case combine x y of+simplifyHead :: LImportDecl GhcPs+             -> [LImportDecl GhcPs]+             -> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])+simplifyHead x (y : ys) = case combine x y of     Nothing -> first (y:) <$> simplifyHead x ys     Just (xy, rs) -> Just (xy : ys, rs)---combine :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan])-combine x y | qual, as, specs = Just (x, [Delete Import (toSS y)])-           | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}-            in Just (newImp, [ Replace Import (toSS x)  [] (prettyPrint newImp)-                             , Delete Import (toSS y) ] )--           | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) =-             let (newImp, toDelete) = if isNothing (importSpecs x) then (x, y) else (y, x)-             in Just (newImp, [Delete Import (toSS toDelete)])-           | not (importQualified x), qual, specs, length ass == 1 =-             let (newImp, toDelete) = if isJust (importAs x) then (x, y) else (y, x)-             in Just (newImp, [Delete Import (toSS toDelete)])+simplifyHead x [] = Nothing +combine :: LImportDecl GhcPs+        -> LImportDecl GhcPs+        -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])+combine x@(GHC.L _ x') y@(GHC.L _ y')+  -- Both (un/)qualified, common 'as', same names : Delete the second.+  | qual, as, specs = Just (x, [Delete Import (toSS' y)])+    -- Both (un/)qualified, common 'as', different names : Merge the+    -- second into the first and delete it.+  | qual, as+  , Just (False, xs) <- ideclHiding x'+  , Just (False, ys) <- ideclHiding y' =+      let newImp = noloc x'{ideclHiding = Just (False, noloc (unloc xs ++ unloc ys))}+      in Just (newImp, [Replace Import (toSS' x) [] (unsafePrettyPrint (unloc newImp))+                       , Delete Import (toSS' y)])+  -- Both (un/qualified), common 'as', one has names the other doesn't+  -- : Delete the one with names.+  | qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') =+       let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)+       in Just (newImp, [Delete Import (toSS' toDelete)])+  -- Both unqualified, same names, one (and only one) has an 'as'+  -- clause : Delete the one without an 'as'.+  | not (ideclQualified x'), qual, specs, length ass == 1 =+       let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)+       in Just (newImp, [Delete Import (toSS' toDelete)])+  -- No hints.+  | otherwise = Nothing     where-        qual = importQualified x == importQualified y-        as = importAs x `eqMaybe` importAs y-        ass = mapMaybe importAs [x,y]-        specs = importSpecs x `eqMaybe` importSpecs y+        qual = ideclQualified x' == ideclQualified y'+        as = ideclAs x' `GHC.Util.eqMaybe` ideclAs y'+        ass = mapMaybe ideclAs [x', y']+        specs = transformBi (const noSrcSpan) (ideclHiding x') ==+                    transformBi (const noSrcSpan) (ideclHiding y') -combine _ _ = Nothing+stripRedundantAlias :: LImportDecl GhcPs -> [Idea]+stripRedundantAlias x@(GHC.L loc i@GHC.ImportDecl {..})+  -- Suggest 'import M as M' be just 'import M'.+  | Just (unloc ideclName) == fmap unloc ideclAs =+      [suggest' "Redundant as" x (GHC.L loc i{ideclAs=Nothing}) [RemoveAsKeyword (toSS' x)]]+stripRedundantAlias _ = [] -combine1 :: ImportDecl S -> [Idea]-combine1 i@ImportDecl{..}-    | Just (dropAnn importModule) == fmap dropAnn importAs-    = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]]-combine1 _ = []+preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]+preferHierarchicalImports x@(GHC.L loc i@GHC.ImportDecl{ideclName=(GHC.L _ n),ideclPkgQual=Nothing})+  -- Suggest 'import IO' be rewritten 'import System.IO, import+  -- System.IO.Error, import Control.Exception(bracket, bracket_)'.+  | n == mkModuleName "IO" && isNothing (ideclHiding i) =+      [rawIdeaN Suggestion "Use hierarchical imports" (ghcSpanToHSE loc)+      (trimStart $ unsafePrettyPrint i) (+          Just $ unlines $ map (trimStart . unsafePrettyPrint)+          [ f "System.IO" Nothing, f "System.IO.Error" Nothing+          , f "Control.Exception" $ Just (False, noloc [mkLIE x | x <- ["bracket","bracket_"]])]) []]+  -- Suggest that a module import like 'Monad' should be rewritten with+  -- its hiearchical equivalent e.g. 'Control.Monad'.+  | Just y <- lookup (moduleNameString n) newNames =+    let newModuleName = y ++ "." ++ moduleNameString n+        r = [Replace R.ModuleName (toSS' x) [] newModuleName] in+    [suggest' "Use hierarchical imports"+     x (noloc (desugarQual i){ideclName=noloc (mkModuleName newModuleName)}) r]+  where+    -- Substitute a new module name.+    f a b = (desugarQual i){ideclName=noloc (mkModuleName a), ideclHiding=b}+    -- Wrap a literal name into an 'IE' (import/export) value.+    mkLIE :: String -> LIE GhcPs+    mkLIE n = noloc $ IEVar noext (noloc (IEName (noloc (mkVarUnqual (fsLit n)))))+    -- Rewrite 'import qualified X' as 'import qualified X as X'.+    desugarQual :: GHC.ImportDecl GhcPs -> GHC.ImportDecl GhcPs+    desugarQual i+      | ideclQualified i && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}+      | otherwise = i +preferHierarchicalImports _ = [] +newNames :: [(String, String)] newNames = let (*) = flip (,) in     ["Control" * "Monad"     ,"Data" * "Char"@@ -118,28 +181,3 @@     -- ,"System" * "Locale"     -- ,"System" * "Time"     ]---hierarchy :: ImportDecl S -> [Idea]-hierarchy i@ImportDecl{importModule=m@(ModuleName _ x),importPkg=Nothing} | Just y <- lookup x newNames-    =-    let newModuleName = y ++ "." ++ x-        r = [Replace R.ModuleName (toSS m) [] newModuleName] in-    [suggest "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r]---- import IO is equivalent to--- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_)-hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing}-    = [rawIdeaN Suggestion "Use hierarchical imports" (srcInfoSpan $ ann i) (trimStart $ prettyPrint i) (-          Just $ unlines $ map (trimStart . prettyPrint)-          [f "System.IO" Nothing, f "System.IO.Error" Nothing-          ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) []]-    where f a b = (desugarQual i){importModule=ModuleName an a, importSpecs=b}--hierarchy _ = []----- import qualified X ==> import qualified X as X-desugarQual :: ImportDecl S -> ImportDecl S-desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}-              | otherwise = x
src/Hint/Match.hs view
@@ -91,7 +91,7 @@ --------------------------------------------------------------------- -- PERFORM THE MATCHING -findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea]+findIdeas :: [HintRule] -> Scope -> ModuleEx -> Decl_ -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList     [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}     | decl <- findDecls decl
src/Hint/Naming.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ViewPatterns #-} {-     Suggest the use of camelCase @@ -11,6 +13,7 @@     Also allow test_ as it's a standard tasty-th idiom     Also allow numbers separated by _     Also don't suggest anything mentioned elsewhere in the module+    Don't suggest for FFI, since they match their C names  <TEST> data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest@@ -19,6 +22,7 @@ data Yes = Foo {bar_cap :: Int} data No = FOO | BarBAR | BarBBar yes_foo = yes_foo + yes_foo -- yesFoo = ...+yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1@@ -31,69 +35,86 @@ _foo__ = 1 section_1_1 = 1 runMutator# = 1+foreign import ccall hexml_node_child :: IO () </TEST> -}   module Hint.Naming(namingHint) where -import Hint.Type-import Data.List.Extra+import Hint.Type (Idea, DeclHint', suggest', transformBi, isSym, toSrcSpan', ghcModule)+import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data import Data.Char import Data.Maybe import Refact.Types hiding (RType(Match)) import qualified Data.Set as Set --namingHint :: DeclHint-namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ moduleDecls modu--naming :: Set.Set String -> Decl_ -> [Idea]-naming seen x = [suggest "Use camelCase" x' x2' [Replace Bind (toSS x) [] (prettyPrint x2)] | not $ null res]-    where res = [(n,y) | n <- nubOrd $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]-          x2 = replaceNames res x-          x' = shorten x-          x2' = shorten x2+import GHC.Util+import "ghc-lib-parser" BasicTypes+import "ghc-lib-parser" FastString+import "ghc-lib-parser" HsDecls+import "ghc-lib-parser" HsExtension+import "ghc-lib-parser" HsSyn+import "ghc-lib-parser" OccName+import "ghc-lib-parser" SrcLoc +namingHint :: DeclHint'+namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ hsmodDecls $ unLoc (ghcModule modu) -shorten :: Decl_ -> Decl_-shorten x = case x of-    FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d]-    PatBind a b c _ -> f (PatBind a b) c-    x -> x+naming :: Set.Set String -> LHsDecl GhcPs -> [Idea]+naming seen originalDecl =+    [ suggest' "Use camelCase"+               (shorten originalDecl)+               (shorten replacedDecl)+               [Replace Bind (toSrcSpan' originalDecl) [] (unsafePrettyPrint replacedDecl)]+    | not $ null suggestedNames+    ]     where-        dots = Var an ellipses-        f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing-        f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing+        suggestedNames =+            [ (originalName, suggestedName)+            | not $ isForD $ unloc originalDecl+            , originalName <- nubOrd $ getNames originalDecl+            , Just suggestedName <- [suggestName originalName]+            , not $ suggestedName `Set.member` seen+            ]+        replacedDecl = replaceNames suggestedNames originalDecl +shorten :: LHsDecl GhcPs -> LHsDecl GhcPs+shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (L locMatches matches) _) _ _))) =+    L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})+shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =+    L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}})+shorten x = x -getNames :: Decl_ -> [String]-getNames x = case x of-    FunBind{} -> name-    PatBind{} -> name-    TypeDecl{} -> name-    DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]-    GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ _ _ _ <- cons]-    TypeFamDecl{} -> name-    DataFamDecl{} -> name-    ClassDecl{} -> name-    _ -> []+shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)+shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =+    L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}}+shortenMatch x = x++shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)+shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =+    L locGRHS (GRHS ttg0 guards (L locExpr dots))     where-        name = [fromNamed x]+        dots :: HsExpr GhcPs+        dots = HsLit NoExt (HsString (SourceText "...") (mkFastString "..."))+shortenLGRHS x = x -        f (ConDecl _ x _) = [x]-        f (InfixConDecl _ _ x _) = [x]-        f (RecDecl _ x _) = [x]+getNames :: LHsDecl GhcPs -> [String]+getNames (L _ decl) = declName decl : getConstructorNames decl +getConstructorNames :: HsDecl GhcPs -> [String]+getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) =+    concatMap (map unsafePrettyPrint . getConNames . unLoc) cons+getConstructorNames _ = []  suggestName :: String -> Maybe String-suggestName x-    | isSym x || good || not (any isLower x) || any isDigit x ||-        any (`isPrefixOf` x) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing-    | otherwise = Just $ f x+suggestName original+    | isSym original || good || not (any isLower original) || any isDigit original ||+        any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing+    | otherwise = Just $ f original     where-        good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' x+        good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' original         drp x = dropWhile (== x)          f xs = us ++ g ys@@ -105,8 +126,8 @@                  | otherwise = g xs         g [] = [] --replaceNames :: Data a => [(String,String)] -> a -> a-replaceNames rep = transformBi f-    where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep-          f x = x+replaceNames :: Data a => [(String, String)] -> a -> a+replaceNames rep = transformBi replace+    where+        replace :: OccName -> OccName+        replace (unsafePrettyPrint -> name) = mkOccName srcDataName $ fromMaybe name $ lookup name rep
src/Hint/NewType.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PackageImports #-} {-     Suggest newtype instead of data for type declarations that have     only one field. Don't suggest newtype for existentially@@ -10,58 +12,129 @@ data Foo a b = Foo a -- newtype Foo a b = Foo a data Foo = Foo { field1, field2 :: Int} data S a = forall b . Show b => S b+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a+data Foo a = () => Foo a -- newtype Foo a = Foo a data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int data A = A {b :: !C} -- newtype A = A {b :: C} data A = A Int# {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #)+{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)} data A = A () -- newtype A = A ()-newtype Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving newtype (Show, Eq)-newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo { getFoo :: Int } deriving newtype (Show, Eq)+newtype Foo = Foo Int deriving (Show, Eq) --+newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo Int deriving stock Show </TEST> -} module Hint.NewType (newtypeHint) where -import Hint.Type+import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN') -newtypeHint :: DeclHint+import Data.List (isSuffixOf)+import "ghc-lib-parser" HsDecls+import "ghc-lib-parser" HsSyn+import "ghc-lib-parser" Outputable+import "ghc-lib-parser" SrcLoc++newtypeHint :: DeclHint' newtypeHint _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x -newtypeHintDecl :: Decl_ -> [Idea]-newtypeHintDecl x-    | Just (DataType s, t, f) <- singleSimpleField x-    = [(suggestN "Use newtype instead of data" x $ f (NewType s) $ fromTyBang t)-            {ideaNote = [DecreasesLaziness | not $ isTyBang t]}]+newtypeHintDecl :: LHsDecl GhcPs -> [Idea]+newtypeHintDecl old+    | Just WarnNewtype{newDecl, insideType} <- singleSimpleField old+    = [(suggestN' "Use newtype instead of data" old newDecl)+            {ideaNote = [DecreasesLaziness | warnBang insideType]}] newtypeHintDecl _ = [] +newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]+newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =+    [ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef]+newTypeDerivingStrategiesHintDecl _ = [] -singleSimpleField :: Decl_ -> Maybe (DataOrNew S, Type_, DataOrNew S -> Type_ -> Decl_)-singleSimpleField (DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing Nothing ctor] x4)-    | Just (t, ft) <- f ctor = Just (dt, t, \dt t -> DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing Nothing $ ft t] x4)-    where-        f (ConDecl x1 x2 [t]) | not $ isKindHash t = Just (t, \t -> ConDecl x1 x2 [t])-        f (RecDecl x1 x2 [FieldDecl y1 [y2] t]) = Just (t, \t -> RecDecl x1 x2 [FieldDecl y1 [y2] t])-        f _ = Nothing+hasAllStrategies :: HsDataDefn GhcPs -> Bool+hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs+hasAllStrategies _ = False++isData :: HsDataDefn GhcPs -> Bool+isData (HsDataDefn _ NewType _ _ _ _ _) = False+isData (HsDataDefn _ DataType _ _ _ _ _) = True+isData _ = False++hasStrategyClause :: LHsDerivingClause GhcPs -> Bool+hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True+hasStrategyClause _ = False++data WarnNewtype = WarnNewtype+    { newDecl :: LHsDecl GhcPs+    , insideType :: HsType GhcPs+    }++-- | Given a declaration, returns the suggested \"newtype\"ized declaration following these guidelines:+-- * Types ending in a \"#\" are __ignored__, because they are usually unboxed primitives - @data X = X Int#@+-- * @ExistentialQuantification@ stuff is __ignored__ - @data X = forall t. X t@+-- * Constructors with (nonempty) constraints are __ignored__ - @data X a = (Eq a) => X a@+-- * Single field constructors get newtyped - @data X = X Int@ -> @newtype X = X Int@+-- * Single record field constructors get newtyped - @data X = X {getX :: Int}@ -> @newtype X = X {getX :: Int}@+-- * All other declarations are ignored.+singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype+singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [L _ constructor] _))))+    | Just inType <- simpleCons constructor =+        Just WarnNewtype+              { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef+                  { dd_ND = NewType+                  , dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef+                  }}+              , insideType = inType+              } singleSimpleField _ = Nothing -newTypeDerivingStrategiesHintDecl :: Decl_ -> [Idea]-newTypeDerivingStrategiesHintDecl x = [ignoreN "Use DerivingStrategies" x new | Just new <- [newtypeDecl x]]+-- | Checks whether its argument is a \"simple constructor\" (see criteria in 'singleSimpleFieldNew')+-- returning the type inside the constructor if it is. This is needed for strictness analysis.+simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)+simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [L _ inType]) _)+    | emptyOrNoContext context+    , not $ isUnboxedTuple inType+    , not $ isHashy inType+    = Just inType+simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)+    | emptyOrNoContext context+    , not $ isUnboxedTuple inType+    , not $ isHashy inType+    = Just inType+simpleCons _ = Nothing -newtypeDecl :: Decl_ -> Maybe Decl_-newtypeDecl (DataDecl x1 x2@(NewType _) x3 x4 x5 x6)-    | any hasNoStrategy x6 = Just $ DataDecl x1 x2 x3 x4 x5 (withNewtype <$> x6)-newtypeDecl (GDataDecl x1 x2@(NewType _) x3 x4 x5 x6 x7)-    | any hasNoStrategy x7 = Just $ GDataDecl x1 x2 x3 x4 x5 x6 (withNewtype <$> x7)-newtypeDecl _ = Nothing+isHashy :: HsType GhcPs -> Bool+isHashy (HsTyVar _ _ identifier) = "#" `isSuffixOf` showSDocUnsafe (ppr identifier)+isHashy _ = False -hasNoStrategy :: Deriving a -> Bool-hasNoStrategy (Deriving _ Nothing _) = True-hasNoStrategy _                      = False+warnBang :: HsType GhcPs -> Bool+warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = False+warnBang _ = True -withNewtype :: Deriving a -> Deriving a-withNewtype (Deriving l Nothing rs)  = Deriving l (Just $ DerivNewtype l) rs-withNewtype d                        = d+emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool+emptyOrNoContext Nothing = True+emptyOrNoContext (Just (L _ [])) = True+emptyOrNoContext _ = False++-- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas!+dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =+    decl {con_args = PrefixCon $ map getBangType fields}+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =+    decl {con_args = RecCon $ L recloc $ removeUnpacksRecords conDeclFields}+    where+        removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]+        removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)++        removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs+        removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =+            conDeclField {cd_fld_type = getBangType fieldType}+        removeConDeclFieldUnpacks x = x+dropConsBang x = x++isUnboxedTuple :: HsType GhcPs -> Bool+isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True+isUnboxedTuple _ = False
src/Hint/Pattern.hs view
@@ -76,7 +76,7 @@         noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c         noPatBind x = x -        strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas modu, Ident _ n <- ns]+        strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas (hseModule modu), Ident _ n <- ns]   hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]
src/Hint/Pragma.hs view
@@ -36,9 +36,9 @@   pragmaHint :: ModuHint-pragmaHint _ x = languageDupes lang ++ optToPragma x lang+pragmaHint _ x = languageDupes lang ++ optToPragma (hseModule x) lang     where-        lang = [x | x@LanguagePragma{} <- modulePragmas x]+        lang = [x | x@LanguagePragma{} <- modulePragmas (hseModule x)]  optToPragma :: Module_ -> [ModulePragma S] -> [Idea] optToPragma x lang =
src/Hint/Restrict.hs view
@@ -26,11 +26,11 @@ -- FIXME: The settings should be partially applied, but that's hard to orchestrate right now restrictHint :: [Setting] -> ModuHint restrictHint settings scope m =-        checkPragmas modu (modulePragmas m) restrict ++-        maybe [] (checkImports modu $ moduleImports m) (Map.lookup RestrictModule restrict) ++-        maybe [] (checkFunctions modu $ moduleDecls m) (Map.lookup RestrictFunction restrict)+        checkPragmas modu (modulePragmas (hseModule m)) restrict +++        maybe [] (checkImports modu $ moduleImports (hseModule m)) (Map.lookup RestrictModule restrict) +++        maybe [] (checkFunctions modu $ moduleDecls (hseModule m)) (Map.lookup RestrictFunction restrict)     where-        modu = moduleName m+        modu = moduleName (hseModule m)         restrict = restrictions settings  ---------------------------------------------------------------------
src/Hint/Smell.hs view
@@ -85,7 +85,7 @@ import qualified Data.Map as Map  smellModuleHint :: [Setting] -> ModuHint-smellModuleHint settings scope m@(moduleImports -> imports) = case Map.lookup SmellManyImports (smells settings) of+smellModuleHint settings scope (moduleImports . hseModule -> imports) = case Map.lookup SmellManyImports (smells settings) of   Just n | length imports >= n ->            let span = foldl1 mergeSrcSpan $ srcInfoSpan . ann <$> imports                displayImports = unlines $ f <$> imports
src/Hint/Type.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE PackageImports #-}  module Hint.Type(-    DeclHint, ModuHint, CrossHint, Hint(..),+    DeclHint, DeclHint', ModuHint, CrossHint, Hint(..),     module Export     ) where @@ -10,20 +11,22 @@ import Idea     as Export import Prelude import Refact   as Export-+import "ghc-lib-parser" HsExtension+import "ghc-lib-parser" HsDecls -type DeclHint = Scope -> Module_ -> Decl_ -> [Idea]-type ModuHint = Scope -> Module_          -> [Idea]-type CrossHint = [(Scope, Module_)] -> [Idea]+type DeclHint = Scope -> ModuleEx -> Decl_ -> [Idea]+type DeclHint' = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]+type ModuHint = Scope -> ModuleEx -> [Idea]+type CrossHint = [(Scope, ModuleEx)] -> [Idea]  -- | Functions to generate hints, combined using the 'Monoid' instance. data Hint {- PUBLIC -} = Hint-    {hintModules :: [Setting] -> [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.-    ,hintModule :: [Setting] -> Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.-    ,hintDecl :: [Setting] -> Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]+    { hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.+    , hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.+    , hintDecl :: [Setting] -> Scope -> ModuleEx -> Decl SrcSpanInfo -> [Idea]+    , hintDecl' :: [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]         -- ^ Given a declaration (with a module and scope) generate some 'Idea's.         --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.-    ,hintComment :: [Setting] -> Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.     }  instance Semigroup Hint where@@ -31,8 +34,8 @@         (\a b -> x1 a b ++ y1 a b)         (\a b c -> x2 a b c ++ y2 a b c)         (\a b c d -> x3 a b c d ++ y3 a b c d)-        (\a b -> x4 a b ++ y4 a b)+        (\a b c d -> x4 a b c d ++ y4 a b c d)  instance Monoid Hint where-    mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> [])+    mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ _ _ -> [])     mappend = (<>)
src/Hint/Unsafe.hs view
@@ -33,7 +33,7 @@         , isUnsafeDecl d, x `notElem_` noinline]     where         gen x = InlineSig an False Nothing $ UnQual an x-        noinline = [q | InlineSig _ False Nothing (UnQual _ q) <- moduleDecls m]+        noinline = [q | InlineSig _ False Nothing (UnQual _ q) <- moduleDecls (hseModule m)]  isUnsafeDecl :: Decl_ -> Bool isUnsafeDecl (PatBind _ _ rhs bind) =
src/Idea.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-}+{-# LANGUAGE PackageImports #-}  module Idea(     Idea(..),-    rawIdea, idea, suggest, warn, ignore,-    rawIdeaN, suggestN, ignoreN,+    rawIdea, idea, idea', suggest, suggest', warn, warn',ignore, ignore',+    rawIdeaN, suggestN, suggestN', ignoreN, ignoreNoSuggestion',     showIdeasJson, showANSI,     Note(..), showNotes,-    Severity(..)+    Severity(..),     ) where  import Data.Functor@@ -17,7 +18,9 @@ import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R import Prelude-+import qualified "ghc-lib-parser" SrcLoc as GHC+import qualified "ghc-lib-parser" Outputable+import qualified GHC.Util as GHC  -- | An idea suggest by a 'Hint'. data Idea = Idea@@ -79,17 +82,65 @@             where xs = lines $ tt x  +rawIdea :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea rawIdea = Idea [] []+rawIdeaN :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea rawIdeaN a b c d e f = Idea [] [] a b c d e f [] +idea :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+        Severity -> String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea idea severity hint from to = rawIdea severity hint (srcInfoSpan $ ann from) (f from) (Just $ f to) []     where f = trimStart . prettyPrint +idea' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+         Severity -> String -> a -> a -> [Refactoring R.SrcSpan] -> Idea+idea' severity hint from to =+  rawIdea severity hint (ghcSpanToHSE (GHC.getLoc from)) (GHC.unsafePrettyPrint from) (Just $ GHC.unsafePrettyPrint to) []++suggest :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+           String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea suggest = idea Suggestion++suggest' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+            String -> a -> a -> [Refactoring R.SrcSpan] -> Idea+suggest' = idea' Suggestion++warn :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+        String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea warn = idea Warning++warn' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+         String -> a -> a -> [Refactoring R.SrcSpan] -> Idea+warn' = idea' Warning++ignoreNoSuggestion' :: (GHC.HasSrcSpan a, Outputable.Outputable a)+                    => String -> a -> Idea+ignoreNoSuggestion' hint x = rawIdeaN Ignore hint (ghcSpanToHSE (GHC.getLoc x)) (GHC.unsafePrettyPrint x) Nothing []++ignore :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+          String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea ignore = idea Ignore +ignore' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+           String -> a -> a -> [Refactoring R.SrcSpan] -> Idea+ignore' = idea' Ignore++ideaN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+         Severity -> String -> ast SrcSpanInfo -> a -> Idea ideaN severity hint from to = idea severity hint from to [] +ideaN' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+          Severity -> String -> a -> a -> Idea+ideaN' severity hint from to = idea' severity hint from to []++suggestN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+            String -> ast SrcSpanInfo -> a -> Idea suggestN = ideaN Suggestion++suggestN' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+             String -> a -> a -> Idea+suggestN' = ideaN' Suggestion++ignoreN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) =>+           String -> ast SrcSpanInfo -> a -> Idea ignoreN = ideaN Ignore
src/Language/Haskell/HLint4.hs view
@@ -23,7 +23,7 @@     -- * Hints     Hint, resolveHints,     -- * Parse files-    ModuleEx, parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)+    ModuleEx, parseModuleEx, createModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)     ) where  import Config.Type@@ -34,6 +34,9 @@ import HSE.All import Hint.All hiding (resolveHints) import qualified Hint.All as H+import qualified ApiAnnotation as GHC+import qualified HsSyn as GHC+import SrcLoc import CmdLine import Paths_hlint @@ -127,8 +130,7 @@ --   which is slower and often pointless (by default HLint passes modules singularly, using --   @--cross@ to pass all modules together). applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]-applyHints a b = H.applyHints a b . map pm_hsext-+applyHints = H.applyHints  -- | Snippet from the documentation, if this changes, update the documentation _docs :: IO ()@@ -136,3 +138,10 @@     (flags, classify, hint) <- autoSettings     Right m <- parseModuleEx flags "MyFile.hs" Nothing     print $ applyHints classify hint [m]+++-- | Create a 'ModuleEx' from GHC annotations and module tree.+--   Note that any hints that work on the @haskell-src-exts@ won't work.+createModuleEx:: GHC.ApiAnns -> Located (GHC.HsModule GHC.GhcPs) -> ModuleEx+createModuleEx anns ast = ModuleEx empty [] ast anns+    where empty = Module an Nothing [] [] []
src/Refact.hs view
@@ -1,8 +1,15 @@-module Refact(toRefactSrcSpan, toSS) where+{-# LANGUAGE PackageImports #-}+module Refact+    ( toRefactSrcSpan+    , toSS, toSS'+    , toSrcSpan'+    ) where  import qualified Refact.Types as R import HSE.All +import qualified "ghc-lib-parser" SrcLoc as GHC+ toRefactSrcSpan :: SrcSpan -> R.SrcSpan toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss)                                (srcSpanStartColumn ss)@@ -11,3 +18,18 @@  toSS :: Annotated a => a S -> R.SrcSpan toSS = toRefactSrcSpan . srcInfoSpan . ann++-- | Don't crash in case ghc gives us a \"fake\" span,+-- opting instead to show @0 0 0 0@ coordinates.+toSrcSpan' :: GHC.HasSrcSpan a => a -> R.SrcSpan+toSrcSpan' x = case GHC.getLoc x of+    GHC.RealSrcSpan span ->+        R.SrcSpan (GHC.srcSpanStartLine span)+                  (GHC.srcSpanStartCol span)+                  (GHC.srcSpanEndLine span)+                  (GHC.srcSpanEndCol span)+    GHC.UnhelpfulSpan _ ->+        R.SrcSpan 0 0 0 0++toSS' :: GHC.Located e -> R.SrcSpan+toSS' = toRefactSrcSpan . ghcSpanToHSE . GHC.getLoc