hlint 2.2.2 → 2.2.3
raw patch · 59 files changed
+2901/−886 lines, 59 filesdep +ghcdep +ghc-boot-thdep +mtldep ~ghc-lib-parserPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc, ghc-boot-th, mtl, syb
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
Files
- CHANGES.txt +8/−0
- README.md +5/−1
- data/hlint.yaml +37/−12
- hlint.cabal +35/−3
- src/Apply.hs +3/−4
- src/CC.hs +0/−1
- src/CmdLine.hs +1/−1
- src/Config/Haskell.hs +3/−3
- src/Config/Type.hs +1/−0
- src/Config/Yaml.hs +8/−3
- src/GHC/Util.hs +50/−261
- src/GHC/Util/ApiAnnotation.hs +103/−0
- src/GHC/Util/Brackets.hs +154/−0
- src/GHC/Util/DynFlags.hs +43/−0
- src/GHC/Util/FreeVars.hs +258/−0
- src/GHC/Util/HsDecl.hs +32/−0
- src/GHC/Util/HsExpr.hs +224/−0
- src/GHC/Util/HsType.hs +14/−0
- src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs +377/−0
- src/GHC/Util/LanguageExtensions/Type.hs +13/−0
- src/GHC/Util/Module.hs +11/−0
- src/GHC/Util/Outputable.hs +14/−0
- src/GHC/Util/Pat.hs +44/−0
- src/GHC/Util/Refact/Fixity.hs +204/−0
- src/GHC/Util/Refact/Utils.hs +166/−0
- src/GHC/Util/SrcLoc.hs +23/−0
- src/GHC/Util/View.hs +48/−0
- src/GHC/Util/W.hs +46/−0
- src/HSE/All.hs +47/−16
- src/HSE/Match.hs +1/−8
- src/HSE/Unify.hs +2/−1
- src/HSE/Util.hs +1/−1
- src/Hint/All.hs +11/−8
- src/Hint/Bracket.hs +127/−64
- src/Hint/Comment.hs +6/−6
- src/Hint/Duplicate.hs +39/−16
- src/Hint/Export.hs +17/−16
- src/Hint/Extensions.hs +0/−1
- src/Hint/Import.hs +35/−30
- src/Hint/List.hs +180/−111
- src/Hint/ListRec.hs +139/−87
- src/Hint/Match.hs +1/−0
- src/Hint/Monad.hs +3/−0
- src/Hint/Naming.hs +22/−20
- src/Hint/NewType.hs +16/−17
- src/Hint/Pragma.hs +81/−53
- src/Hint/Restrict.hs +64/−40
- src/Hint/Smell.hs +71/−35
- src/Hint/Type.hs +2/−3
- src/Hint/Unsafe.hs +56/−24
- src/Hint/Util.hs +1/−17
- src/Idea.hs +21/−11
- src/Language/Haskell/HLint4.hs +11/−4
- src/Refact.hs +2/−3
- src/Test/All.hs +3/−2
- src/Test/Annotations.hs +1/−0
- src/Test/Proof.hs +1/−0
- src/Test/Translate.hs +1/−0
- src/Util.hs +14/−3
CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for HLint (* = breaking change) +2.2.3, released 2019-09-29+ #766, turn on more extensions when parsing config files+ #255, don't match variables with type application+ Switch to ghc-parser-8.8.1+ Slightly restrict the replace case with fromMaybe hint+ #701, add hints for replacing case with maybe+ #724, suggest Data.Bifunctor in some places+ #725, allow custom message for restricted items 2.2.2, released 2019-07-23 #716, upgrade to ghc-lib-parser 8.8.0.20190723 2.2.1, released 2019-07-22
README.md view
@@ -118,7 +118,7 @@ ### Language Extensions -HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Individual extensions can be enabled or disabled with, for instance, `-XArrows`, or `-XNoMagicHash`. The flag `-XHaskell2010` selects Haskell 2010 compatibility. You can also pass them via `.hlint.yaml` file. For example: `- arguments: [-XQuasiQuotes]`.+HLint enables most Haskell extensions, disabling only those which steal too much syntax (e.g. Arrows, TransformListComp and TypeApplications). Individual extensions can be enabled or disabled with, for instance, `-XArrows`, or `-XNoMagicHash`. The flag `-XHaskell2010` selects Haskell 2010 compatibility. You can also pass them via `.hlint.yaml` file. For example: `- arguments: [-XArrows]`. ### Emacs Integration @@ -261,6 +261,8 @@ These directives are applied in the order they are given, with later hints overriding earlier ones. +You can choose to ignore all hints with `- ignore: {}` then selectively enable the ones you want (e.g. `- warn: {name: Use const}`), but it isn't a totally smooth experience (see [#747](https://github.com/ndmitchell/hlint/issues/747) and [#748](https://github.com/ndmitchell/hlint/issues/748)).+ Finally, `hlint` defines the `__HLINT__` preprocessor definition (with value `1`), so problematic definitions (including those that don't parse) can be hidden with: ```haskell@@ -321,6 +323,8 @@ ``` This fragment requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency. It also ensures the module `Control.Arrow` can't be used anywhere.++You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`). ## Hacking HLint
data/hlint.yaml view
@@ -15,6 +15,7 @@ - import Data.Foldable(asum, sequenceA_, traverse_, for_) - import Data.Traversable(traverse, for) - import Control.Applicative+ - import Data.Bifunctor - import Data.Function - import Data.Int - import Data.Char@@ -280,7 +281,7 @@ - hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)} # If any isWildcard recursively then x may be used but not mentioned explicitly - warn: {lhs: flip f x y, rhs: f y x, side: isApp original}- - warn: {lhs: id x, rhs: x, side: not (isTypeApp x)}+ - warn: {lhs: id x, rhs: x} - warn: {lhs: id . x, rhs: x, name: Redundant id} - warn: {lhs: x . id, rhs: x, name: Redundant id} - warn: {lhs: "((,) x)", rhs: "(_noParen_ x,)", name: Use tuple-section, note: RequiresExtension TupleSections}@@ -335,13 +336,32 @@ - warn: {lhs: id *** g, rhs: second g} - warn: {lhs: f *** id, rhs: first f} - ignore: {lhs: zip (map f x) (map g x), rhs: map (f Control.Arrow.&&& g) x}- - ignore: {lhs: "\\(x,y) -> (f x, g y)", rhs: f Control.Arrow.*** g} - ignore: {lhs: "\\x -> (f x, g x)", rhs: f Control.Arrow.&&& g}- - ignore: {lhs: "\\(x,y) -> (f x,y)", rhs: Control.Arrow.first f}- - ignore: {lhs: "\\(x,y) -> (x,f y)", rhs: Control.Arrow.second f}- - ignore: {lhs: "(f (fst x), g (snd x))", rhs: (f Control.Arrow.*** g) x} - hint: {lhs: "(fst x, snd x)", rhs: x, note: DecreasesLaziness, name: Redundant pair} + # BIFUNCTOR++ - warn: {lhs: bimap id g, rhs: second g}+ - warn: {lhs: bimap f id, rhs: first f}+ - warn: {lhs: first id, rhs: id}+ - warn: {lhs: second id, rhs: id}+ - warn: {lhs: bimap id id, rhs: id}+ - warn: {lhs: first f (second g x), rhs: bimap f g x}+ - warn: {lhs: second g (first f x), rhs: bimap f g x}+ - warn: {lhs: first f1 (first f2 x), rhs: first (f1 . f2) x}+ - warn: {lhs: second g1 (second g2 x), rhs: second (g1 . g2) x}+ - warn: {lhs: bimap f1 f2 (bimap g1 g2 x), rhs: bimap (f1 . f2) (g1 . g2) x}+ - warn: {lhs: first f1 (bimap f2 g x), rhs: bimap (f1 . f2) g x}+ - warn: {lhs: second g1 (bimap f g2 x), rhs: bimap f (g1 . g2) x}+ - warn: {lhs: bimap f1 g (first f2 x), rhs: bimap (f1 . f2) g x}+ - warn: {lhs: bimap f g1 (second g2 x), rhs: bimap f (g1 . g2) x}+ - hint: {lhs: "\\(x,y) -> (f x, g y)", rhs: Data.Bifunctor.bimap f g, note: IncreasesLaziness}+ - hint: {lhs: "\\(x,y) -> (f x,y)", rhs: Data.Bifunctor.first f, note: IncreasesLaziness}+ - hint: {lhs: "\\(x,y) -> (x,f y)", rhs: Data.Bifunctor.second f, note: IncreasesLaziness}+ - hint: {lhs: "(f (fst x), g (snd x))", rhs: Data.Bifunctor.bimap f g x}+ - hint: {lhs: "(f (fst x), snd x)", rhs: Data.Bifunctor.first f x}+ - hint: {lhs: "(fst x, g (snd x))", rhs: Data.Bifunctor.second g x}+ # FUNCTOR - warn: {lhs: fmap f (fmap g x), rhs: fmap (f . g) x, name: Functor law}@@ -487,8 +507,10 @@ - warn: {lhs: "maybe [] (:[])", rhs: maybeToList} - warn: {lhs: catMaybes (map f x), rhs: mapMaybe f x} - warn: {lhs: catMaybes (fmap f x), rhs: mapMaybe f x}- - hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, name: Replace case with fromMaybe}- - hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, name: Replace case with fromMaybe}+ - hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}+ - hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}+ - hint: {lhs: case x of Nothing -> y; Just a -> f a , rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe}+ - hint: {lhs: case x of Just a -> f a; Nothing -> y, rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe} - warn: {lhs: if isNothing x then y else f (fromJust x), rhs: maybe y f x} - warn: {lhs: if isJust x then f (fromJust x) else y, rhs: maybe y f x} - warn: {lhs: maybe Nothing (Just . f), rhs: fmap f}@@ -515,7 +537,7 @@ - warn: {lhs: maybe x f (fmap g y), rhs: maybe x (f . g) y, name: Redundant fmap} - warn: {lhs: isJust (fmap f x), rhs: isJust x} - warn: {lhs: isNothing (fmap f x), rhs: isNothing x}- - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x)}+ - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x), note: IncreasesLaziness} - warn: {lhs: mapMaybe f (fmap g x), rhs: mapMaybe (f . g) x, name: Redundant fmap} # EITHER@@ -752,6 +774,8 @@ - warn: {lhs: map, rhs: fmap} - warn: {lhs: a ++ b, rhs: a <> b} - warn: {lhs: "sequence [a]", rhs: "pure <$> a"}+ - warn: {lhs: "x /= []", rhs: not (null x), name: Use null}+ - warn: {lhs: "[] /= x", rhs: not (null x), name: Use null} - group: name: generalise-for-conciseness@@ -787,7 +811,6 @@ - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law} - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law} - # <TEST> # yes = concat . map f -- concatMap f # yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar@@ -826,7 +849,7 @@ # yes = head (reverse xs) -- last xs # yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys # no = putStrLn $ show (length xs) ++ "Test"-# yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper Control.Arrow.*** urlEncode+# yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- Data.Bifunctor.bimap toUpper urlEncode # yes = map (\(a,b) -> a) xs -- fst # yes = map (\(a,_) -> a) xs -- fst # yes = readFile $ args !! 0 -- head args@@ -836,7 +859,7 @@ # yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \ # -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff # yes = if foo then stuff else return () -- Control.Monad.when foo stuff-# yes = foo $ \(a, b) -> (a, y + b) -- Control.Arrow.second ((+) y)+# yes = foo $ \(a, b) -> (a, y + b) -- Data.Bifunctor.second ((+) y) # no = foo $ \(a, b) -> (a, a + b) # yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10] # no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter@@ -860,7 +883,7 @@ # yes x = case x of {True -> a ; False -> b} -- if x then a else b # yes x = case x of {False -> a ; _ -> b} -- if x then b else a # no = const . ok . toResponse $ "saved"-# yes = case x z of Nothing -> y z; Just pat -> pat -- Data.Maybe.fromMaybe (y z) (x z)+# yes = case x z of Nothing -> y; Just pat -> pat -- Data.Maybe.fromMaybe y (x z) # yes = if p then s else return () -- Control.Monad.when p s # warn = a $$$$ b $$$$ c ==> a . b $$$$$ c # yes = when (not . null $ asdf) -- unless (null asdf)@@ -931,6 +954,8 @@ # mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x # {-# LANGUAGE TypeApplications #-} \ # foo = id @Int+# {-# LANGUAGE TypeApplications #-} \+# foo = const @_ @SomeException # foo = id 12 -- 12 # yes = foldr (\ curr acc -> (+ 1) curr : acc) [] -- map (\ curr -> (+ 1) curr) # yes = foldr (\ curr acc -> curr + curr : acc) [] -- map (\ curr -> curr + curr)
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 2.2.2+version: 2.2.3 license: BSD3 license-file: LICENSE category: Development@@ -27,7 +27,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==8.6.5, GHC==8.4.4+tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4 source-repository head type: git@@ -43,6 +43,11 @@ manual: True description: Use GPL libraries, specifically hscolour +flag ghc-lib+ default: False+ manual: True+ description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported+ library default-language: Haskell2010 build-depends:@@ -60,7 +65,15 @@ extra >= 1.6.6, refact >= 0.3, aeson >= 1.1.2.0,- ghc-lib-parser == 8.8.0.20190723+ syb >= 0.7,+ mtl >= 2.2.2+ if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)+ build-depends:+ ghc == 8.8.*,+ ghc-boot-th+ else+ build-depends:+ ghc-lib-parser == 8.8.1 if flag(gpl) build-depends: hscolour >= 1.21@@ -91,7 +104,26 @@ Config.Read Config.Type Config.Yaml+ GHC.Util+ GHC.Util.ApiAnnotation+ GHC.Util.View+ GHC.Util.Brackets+ GHC.Util.FreeVars+ GHC.Util.HsDecl+ GHC.Util.HsExpr+ GHC.Util.HsType+ GHC.Util.Pat+ GHC.Util.LanguageExtensions.Type+ GHC.Util.Module+ GHC.Util.Outputable+ GHC.Util.SrcLoc+ GHC.Util.W+ GHC.Util.DynFlags+ GHC.Util.Language.Haskell.GHC.ExactPrint.Types+ GHC.Util.Refact.Utils+ GHC.Util.Refact.Fixity+ HSE.All HSE.Match HSE.Reduce
src/Apply.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PackageImports #-} module Apply(applyHints, applyHintFile, applyHintFiles) where @@ -15,8 +14,8 @@ import Data.Ord import Config.Type import Config.Haskell-import "ghc-lib-parser" HsSyn-import qualified "ghc-lib-parser" SrcLoc as GHC+import HsSyn+import qualified SrcLoc as GHC import qualified Data.HashSet as Set import Prelude @@ -52,7 +51,7 @@ [ map (classify classifiers . removeRequiresExtensionNotes (hseModule m)) $ order [] (hintModule hints settings nm m) `merge` 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]+ concat [order (maybeToList $ 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
src/CC.hs view
@@ -12,7 +12,6 @@ import Data.Aeson (ToJSON(..), (.=), encode, object) import Data.Char (toUpper)-import Data.Monoid ((<>)) import Data.Text (Text) import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
src/CmdLine.hs view
@@ -308,7 +308,7 @@ getExtensions :: [String] -> (Language, [Extension])-getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts)+getExtensions args = (lang, foldl f (if null langs then parseExtensions else []) exts) where lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls (langs, exts) = partition (isJust . flip lookup ls) args
src/Config/Haskell.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE PackageImports #-} module Config.Haskell( readPragma, readComment,@@ -17,10 +16,11 @@ import Util import Prelude import GHC.Util-import "ghc-lib-parser" SrcLoc as GHC-import "ghc-lib-parser" ApiAnnotation+import SrcLoc as GHC+import ApiAnnotation +addInfix :: ParseFlags -> ParseFlags addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]
src/Config/Type.hs view
@@ -105,6 +105,7 @@ ,restrictName :: [String] ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as ,restrictWithin :: [(String, String)]+ ,restrictMessage :: Maybe String } deriving Show data SmellType = SmellLongFunctions | SmellLongTypeLists | SmellManyArgFunctions | SmellManyImports
src/Config/Yaml.hs view
@@ -116,6 +116,10 @@ parseArrayString :: Val -> Parser [String] parseArrayString = parseArray >=> mapM parseString +maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)+maybeParse parseValue Nothing = return Nothing+maybeParse parseValue (Just value) = Just <$> parseValue value+ parseBool :: Val -> Parser Bool parseBool (getVal -> Bool b) = return b parseBool v = parseFail v "Expected a Bool"@@ -144,7 +148,7 @@ parseHSE :: (ParseMode -> String -> ParseResult v) -> Val -> Parser v parseHSE parser v = do x <- parseString v- case parser defaultParseMode{extensions=defaultExtensions} x of+ case parser defaultParseMode{extensions=configExtensions} x of ParseOk x -> return x ParseFailed loc s -> parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n " ++ x @@ -239,12 +243,13 @@ Just def -> do b <- parseBool def allowFields v ["default"]- return $ Restrict restrictType b [] [] []+ return $ Restrict restrictType b [] [] [] Nothing Nothing -> do restrictName <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString restrictWithin <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin) restrictAs <- parseFieldOpt "as" v >>= maybe (return []) parseArrayString- allowFields v $ ["as" | restrictType == RestrictModule] ++ ["name","within"]+ restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString+ allowFields v $ ["as" | restrictType == RestrictModule] ++ ["name","within", "message"] return Restrict{restrictDefault=True,..} parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
src/GHC/Util.hs view
@@ -1,89 +1,64 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeFamilies, NamedFieldPuns #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-} module GHC.Util (- baseDynFlags- , parsePragmasIntoDynFlags- , parseFileGhcLib- , ParseResult (..)- , pprErrMsgBagWithLoc- , getMessages- , 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+ module GHC.Util.View+ , module GHC.Util.FreeVars+ , module GHC.Util.ApiAnnotation+ , module GHC.Util.HsDecl+ , module GHC.Util.HsExpr+ , module GHC.Util.HsType+ , module GHC.Util.LanguageExtensions.Type+ , module GHC.Util.Pat+ , module GHC.Util.Module+ , module GHC.Util.Outputable+ , module GHC.Util.SrcLoc+ , module GHC.Util.W+ , module GHC.Util.DynFlags++ , parsePragmasIntoDynFlags, parseFileGhcLib ) where -import "ghc-lib-parser" HsSyn-import "ghc-lib-parser" BasicTypes-import "ghc-lib-parser" RdrName-import "ghc-lib-parser" DynFlags-import "ghc-lib-parser" Platform-import "ghc-lib-parser" Fingerprint-import "ghc-lib-parser" Config-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-import "ghc-lib-parser" Outputable-import "ghc-lib-parser" GHC.LanguageExtensions.Type-import "ghc-lib-parser" Panic-import "ghc-lib-parser" HscTypes-import "ghc-lib-parser" HeaderInfo-import "ghc-lib-parser" ApiAnnotation+import GHC.Util.View+import GHC.Util.FreeVars+import GHC.Util.ApiAnnotation+import GHC.Util.HsExpr+import GHC.Util.HsType+import GHC.Util.HsDecl+import GHC.Util.LanguageExtensions.Type+import GHC.Util.Pat+import GHC.Util.Module+import GHC.Util.Outputable+import GHC.Util.SrcLoc+import GHC.Util.W+import GHC.Util.DynFlags +import HsSyn+import Lexer+import Parser+import SrcLoc+import FastString+import StringBuffer+import GHC.LanguageExtensions.Type+import Panic+import HscTypes+import HeaderInfo+import DynFlags+ import Data.List.Extra import System.FilePath import Language.Preprocessor.Unlit-import qualified Data.Map.Strict as Map -fakeSettings :: Settings-fakeSettings = Settings- { sTargetPlatform=platform- , sPlatformConstants=platformConstants- , sProjectVersion=cProjectVersion- , sProgramName="ghc"- , sOpt_P_fingerprint=fingerprint0- }+parseFileGhcLib :: FilePath+ -> String+ -> DynFlags+ -> ParseResult (Located (HsModule GhcPs))+parseFileGhcLib filename str flags =+ Lexer.unP Parser.parseModule parseState where- platform =- Platform{platformWordSize=8- , platformOS=OSUnknown- , platformUnregisterised=True}- platformConstants =- PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}--fakeLlvmConfig :: (LlvmTargets, LlvmPasses)-fakeLlvmConfig = ([], [])--baseDynFlags :: DynFlags-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+ location = mkRealSrcLoc (mkFastString filename) 1 1+ buffer = stringToStringBuffer $+ if takeExtension filename /= ".lhs" then str else unlit filename str+ parseState = mkPState flags buffer location --- | Adjust the input 'DynFlags' to take into account language--- extensions to explicitly enable/disable as well as language--- extensions enabled by pragma in the source. parsePragmasIntoDynFlags :: DynFlags -> ([Extension], [Extension]) -> FilePath@@ -102,189 +77,3 @@ catchErrors act = handleGhcException reportErr (handleSourceError reportErr act) reportErr e = return $ Left (show e)--parseFileGhcLib ::- FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))-parseFileGhcLib filename str flags =- Lexer.unP Parser.parseModule parseState- where- location = mkRealSrcLoc (mkFastString filename) 1 1- buffer = stringToStringBuffer $- if takeExtension filename /= ".lhs" then str else unlit filename str- parseState = mkPState flags buffer location-------------------------------------------------------------------------- The following functions are from--- https://github.com/pepeiborra/haskell-src-exts-util ("Utility code--- for working with haskell-src-exts") rewritten for GHC parse trees--- (of which at least one of them came from this project originally).---- | 'isAtom e' if 'e' requires no bracketing ever.-isAtom :: HsExpr GhcPs -> Bool-isAtom x = case x of- HsVar {} -> True- HsUnboundVar {} -> True- HsRecFld {} -> True- HsOverLabel {} -> True- HsIPVar {} -> True- HsPar {} -> True- SectionL {} -> True- SectionR {} -> True- ExplicitTuple {} -> True- ExplicitSum {} -> True- ExplicitList {} -> True- RecordCon {} -> True- RecordUpd {} -> True- ArithSeq {} -> True- HsBracket {} -> True- HsRnBracketOut {} -> True- HsTcBracketOut {} -> True- HsSpliceE {} -> True- HsLit _ x | not $ isNegativeLit x -> True- HsOverLit _ x | not $ isNegativeOverLit x -> True- _ -> False- where- isNegativeLit (HsInt _ i) = il_neg i- isNegativeLit (HsRat _ f _) = fl_neg f- isNegativeLit (HsFloatPrim _ f) = fl_neg f- isNegativeLit (HsDoublePrim _ f) = fl_neg f- isNegativeLit (HsIntPrim _ x) = x < 0- isNegativeLit (HsInt64Prim _ x) = x < 0- isNegativeLit (HsInteger _ x _) = x < 0- isNegativeLit _ = False-- isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i- isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f- isNegativeOverLit _ = False---- | 'addParen e' wraps 'e' in parens.-addParen :: HsExpr GhcPs -> HsExpr GhcPs-addParen e = HsPar noExt (noLoc e)---- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.-paren :: HsExpr GhcPs -> HsExpr GhcPs-paren x- | isAtom x = x- | otherwise = addParen x---- | 'isApp e' if 'e' is a (regular) application.-isApp :: HsExpr GhcPs -> Bool-isApp x = case x of- HsApp {} -> True- _ -> False---- | 'isOpApp e' if 'e' is an operator application.-isOpApp :: HsExpr GhcPs -> Bool-isOpApp x = case x of- OpApp {} -> True- _ -> False---- | 'isAnyApp e' if 'e' is either an application or operator--- application.-isAnyApp :: HsExpr GhcPs -> Bool-isAnyApp x = isApp x || isOpApp x---- | 'isDot e' if 'e' is the unqualifed variable '.'.-isDot :: HsExpr GhcPs -> Bool-isDot x- | HsVar _ (L _ ident) <- x- , ident == mkVarUnqual (fsLit ".") = True- | otherwise = False---- | 'isSection e' if 'e' is a section.-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---- | 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/GHC/Util/ApiAnnotation.hs view
@@ -0,0 +1,103 @@++module GHC.Util.ApiAnnotation (+ comment, commentText, isCommentMultiline+ , pragmas, flags, langExts+ , mkFlags, mkLangExts+) where++import ApiAnnotation+import SrcLoc++import Control.Applicative+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.List.Extra++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++-- | A comment as a string.+comment :: Located AnnotationComment -> String+comment (L _ (AnnBlockComment s)) = s+comment (L _ (AnnLineComment s)) = s+comment (L _ (AnnDocOptions s)) = s+comment (L _ (AnnDocCommentNamed s)) = s+comment (L _ (AnnDocCommentPrev s)) = s+comment (L _ (AnnDocCommentNext s)) = s+comment (L _ (AnnDocSection _ s)) = s++-- | The comment string with delimiters removed.+commentText :: Located AnnotationComment -> String+commentText = trimCommentDelims . comment++isCommentMultiline :: Located AnnotationComment -> Bool+isCommentMultiline (L _ (AnnBlockComment _)) = True+isCommentMultiline _ = False++-- GHC parse trees don't contain pragmas. We work around this with+-- (nasty) parsing of comments.++-- Pragmas. Comments not associated with a span in the annotations+-- that have the form @{-# ...#-}@.+pragmas :: ApiAnns -> [(Located AnnotationComment, String)]+pragmas anns =+ -- 'ApiAnns' stores pragmas in reverse order to how they were+ -- encountered in the source file with the last at the head of the+ -- list (makes sense when you think about it).+ reverse+ [ (c, s) |+ c@(L _ (AnnBlockComment comm)) <- fromMaybe [] $ Map.lookup noSrcSpan (snd anns)+ , let body = trimCommentDelims comm+ , Just rest <- [stripSuffix "#" =<< stripPrefix "#" body]+ , let s = trim rest+ ]++-- Utility for a case insensitive prefix strip.+stripPrefixCI :: String -> String -> Maybe String+stripPrefixCI pref str =+ let pref' = lower pref+ (str_pref, rest) = splitAt (length pref') str+ in if lower str_pref == pref' then Just rest else Nothing++-- Flags. The first element of the pair is the (located) annotation+-- comment that sets the flags enumerated in the second element of the+-- pair.+flags :: [(Located AnnotationComment, String)]+ -> [(Located AnnotationComment, [String])]+flags ps =+ -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but+ -- this is deprecated).+ [(c, opts) | (c, s) <- ps+ , Just rest <- [stripPrefixCI "OPTIONS_GHC " s+ <|> stripPrefixCI "OPTIONS " s]+ , let opts = words rest]++-- Language extensions. The first element of the pair is the (located)+-- annotation comment that enables the extensions enumerated by he+-- second element of the pair.+langExts :: [(Located AnnotationComment, String)]+ -> [(Located AnnotationComment, [String])]+langExts ps =+ [(c, exts) | (c, s) <- ps+ , Just rest <- [stripPrefixCI "LANGUAGE " s]+ , let exts = map trim (splitOn "," rest)]++-- Given a list of flags, make a GHC options pragma.+mkFlags :: SrcSpan -> [String] -> Located AnnotationComment+mkFlags loc flags =+ LL loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")++mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment+mkLangExts loc exts =+ LL loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")
+ src/GHC/Util/Brackets.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}+module GHC.Util.Brackets (Brackets'(..), isApp',isOpApp',isAnyApp',isSection') where++import HsSyn+import SrcLoc+import BasicTypes++class Brackets' a where+ remParen' :: a -> Maybe a -- Remove one paren or nothing if there is no paren.+ addParen' :: a -> a -- Write out a paren.+ -- | Is this item lexically requiring no bracketing ever i.e. is+ -- totally atomic.+ isAtom' :: a -> Bool+ -- | Is the child safe free from brackets in the parent+ -- position. Err on the side of caution, True = don't know.+ needBracket' :: Int -> a -> a -> Bool++isOpApp', isApp', isSection' :: LHsExpr GhcPs -> Bool+isApp' (LL _ HsApp{}) = True; isApp' _ = False+isOpApp' (LL _ OpApp{}) = True; isOpApp' _ = False+isAnyApp' x = isApp' x || isOpApp' x+isSection' (LL _ SectionL{}) = True; isSection' (LL _ SectionR{}) = True; isSection' _ = False++instance Brackets' (LHsExpr GhcPs) where+ -- When GHC parses a section in concrete syntax, it will produce an+ -- 'HsPar (Section[L|R])'. There is no concrete syntax that will+ -- result in a "naked" section. Consequently, given an expression,+ -- when stripping brackets (c.f. 'Hint.Brackets'), don't remove the+ -- paren's surrounding a section - they are required.+ remParen' (LL _ (HsPar _ (LL _ SectionL{}))) = Nothing+ remParen' (LL _ (HsPar _ (LL _ SectionR{}))) = Nothing+ remParen' (LL _ (HsPar _ x)) = Just x+ remParen' _ = Nothing++ addParen' e = noLoc $ HsPar noExt e++ isAtom' (LL _ x) = case x of+ HsVar{} -> True+ HsUnboundVar{} -> True+ HsRecFld{} -> True+ HsOverLabel{} -> True+ HsIPVar{} -> True+ -- Note that sections aren't atoms (but parenthesized sections are).+ HsPar{} -> True+ ExplicitTuple{} -> True+ ExplicitSum{} -> True+ ExplicitList{} -> True+ RecordCon{} -> True+ RecordUpd{} -> True+ ArithSeq{}-> True+ HsBracket{} -> True+ HsSpliceE {} -> True+ HsOverLit _ x | not $ isNegativeOverLit x -> True+ HsLit _ x | not $ isNegativeLit x -> True+ _ -> False+ where+ isNegativeLit (HsInt _ i) = il_neg i+ isNegativeLit (HsRat _ f _) = fl_neg f+ isNegativeLit (HsFloatPrim _ f) = fl_neg f+ isNegativeLit (HsDoublePrim _ f) = fl_neg f+ isNegativeLit (HsIntPrim _ x) = x < 0+ isNegativeLit (HsInt64Prim _ x) = x < 0+ isNegativeLit (HsInteger _ x _) = x < 0+ isNegativeLit _ = False+ isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i+ isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f+ isNegativeOverLit _ = False+ isAtom' _ = False -- '{-# COMPLETE LL #-}'++ needBracket' i parent child -- Note: i is the index in children, not in the AST.+ | isAtom' child = False+ | isSection' parent, LL _ HsApp{} <- child = False+ | LL _ OpApp{} <- parent, LL _ HsApp{} <- child = False+ | LL _ HsLet{} <- parent, LL _ HsApp{} <- child = False+ | LL _ HsDo{} <- parent = False+ | LL _ ExplicitList{} <- parent = False+ | LL _ ExplicitTuple{} <- parent = False+ | LL _ HsIf{} <- parent, isAnyApp' child = False+ | LL _ HsApp{} <- parent, i == 0, LL _ HsApp{} <- child = False+ | LL _ ExprWithTySig{} <- parent, i == 0, isApp' child = False+ | LL _ RecordCon{} <- parent = False+ | LL _ RecordUpd{} <- parent, i /= 0 = False+ | LL _ HsCase{} <- parent, i /= 0 || isAnyApp' child = False+ | LL _ HsLam{} <- parent = False -- might be either the RHS of a PViewPat, or the lambda body (neither needs brackets)+ | LL _ HsPar{} <- parent = False+ | LL _ HsDo {} <- parent = False+ | otherwise = True++instance Brackets' (Pat GhcPs) where+ remParen' (LL _ (ParPat _ x)) = Just x+ remParen' _ = Nothing+ addParen' e = noLoc $ ParPat noExt e++ isAtom' (LL _ x) = case x of+ ParPat{} -> True+ TuplePat{} -> True+ ListPat{} -> True+ ConPatIn _ RecCon{} -> True+ ConPatIn _ (PrefixCon []) -> True+ VarPat{} -> True+ WildPat{} -> True+ SumPat{} -> True+ AsPat{} -> True+ SplicePat{} -> True+ LitPat _ x | not $ isSignedLit x -> True+ _ -> False+ where+ isSignedLit HsInt{} = True+ isSignedLit HsIntPrim{} = True+ isSignedLit HsInt64Prim{} = True+ isSignedLit HsInteger{} = True+ isSignedLit HsRat{} = True+ isSignedLit HsFloatPrim{} = True+ isSignedLit HsDoublePrim{} = True+ isSignedLit _ = False+ isAtom' _ = False -- '{-# COMPLETE LL #-}'++ needBracket' _ parent child+ | isAtom' child = False+ | LL _ TuplePat{} <- parent = False+ | LL _ ListPat{} <- parent = False+ | otherwise = True++instance Brackets' (LHsType GhcPs) where+ remParen' (LL _ (HsParTy _ x)) = Just x+ remParen' _ = Nothing+ addParen' e = noLoc $ HsParTy noExt e++ isAtom' (LL _ x) = case x of+ HsParTy{} -> True+ HsTupleTy{} -> True+ HsListTy{} -> True+ HsExplicitTupleTy{} -> True+ HsExplicitListTy{} -> True+ HsTyVar{} -> True+ HsSumTy{} -> True+ HsSpliceTy{} -> True+ HsWildCardTy{} -> True+ _ -> False+ isAtom' _ = False -- '{-# COMPLETE LL #-}'++ needBracket' _ parent child+ | isAtom' child = False+-- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc.+-- | TyFun{} <- parent, i == 1, TyFun{} <- child = False+ | LL _ HsFunTy{} <- parent, LL _ HsAppTy{} <- child = False+ | LL _ HsTupleTy{} <- parent = False+ | LL _ HsListTy{} <- parent = False+ | LL _ HsExplicitTupleTy{} <- parent = False+ | LL _ HsListTy{} <- parent = False+ | LL _ HsExplicitListTy{} <- parent = False+ | LL _ HsOpTy{} <- parent, LL _ HsAppTy{} <- child = False+ | LL _ HsParTy{} <- parent = False+ | otherwise = True
+ src/GHC/Util/DynFlags.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module GHC.Util.DynFlags (baseDynFlags) where++import DynFlags+import Platform+import Config+import Fingerprint+import GHC.LanguageExtensions.Type++import Data.List.Extra++fakeSettings :: Settings+fakeSettings = Settings+ { sTargetPlatform=platform+ , sPlatformConstants=platformConstants+ , sProjectVersion=cProjectVersion+ , sProgramName="ghc"+ , sOpt_P_fingerprint=fingerprint0+ }+ where+ platform =+ Platform{platformWordSize=8+ , platformOS=OSUnknown+ , platformUnregisterised=True}+ platformConstants =+ PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}++fakeLlvmConfig :: (LlvmTargets, LlvmPasses)+fakeLlvmConfig = ([], [])++baseDynFlags :: DynFlags+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
+ src/GHC/Util/FreeVars.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.Util.FreeVars (+ vars', varss', pvars', freeVarSet'+ , Vars' (..), FreeVars'(..) , AllVars' (..)+ ) where++import RdrName+import HsTypes+import OccName+import Name+import HsSyn+import SrcLoc+import Bag (bagToList)++import Data.Generics.Uniplate.Data ()+import Data.Generics.Uniplate.Operations+import Data.Monoid+import Data.Semigroup+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude+++( ^+ ) :: Set OccName -> Set OccName -> Set OccName+( ^+ ) = Set.union+( ^- ) :: Set OccName -> Set OccName -> Set OccName+( ^- ) = Set.difference++-- See [Note : Spack leaks lurking here?] below.+data Vars' = Vars'{bound' :: Set OccName, free' :: Set OccName}++instance Semigroup Vars' where+ Vars' x1 x2 <> Vars' y1 y2 = Vars' (x1 ^+ y1) (x2 ^+ y2)++instance Monoid Vars' where+ mempty = Vars' Set.empty Set.empty+ mconcat vs = Vars' (Set.unions $ map bound' vs) (Set.unions $ map free' vs)++-- A type `a` is a model of `AllVars' a` if exists a function+-- `allVars'` for producing a pair of the bound and free varaiable+-- sets in a value of `a`.+class AllVars' a where+ -- | Return the variables, erring on the side of more free+ -- variables.+ allVars' :: a -> Vars'++-- A type `a` is a model of `FreeVars' a` if exists a function+-- `freeVars'` for producing a set of free varaiable of a value of+-- `a`.+class FreeVars' a where+ -- | Return the variables, erring on the side of more free+ -- variables.+ freeVars' :: a -> Set OccName++-- Trivial instances.+instance AllVars' Vars' where allVars' = id+instance FreeVars' (Set OccName) where freeVars' = id+-- [Note : Space leaks lurking here?]+-- ==================================+-- We make use of `foldr`. @cocreature suggests we want bangs on `data+-- Vars` and replace usages of `mconcat` with `foldl'`.+instance (AllVars' a) => AllVars' [a] where allVars' = mconcat . map allVars'+instance (FreeVars' a) => FreeVars' [a] where freeVars' = Set.unions . map freeVars'++-- Construct a `Vars` value with no bound vars.+freeVars_' :: (FreeVars' a) => a -> Vars'+freeVars_' = Vars' Set.empty . freeVars'++-- `inFree' a b` is the set of free variables in 'a' together with the+-- free variables in 'b' not bound in 'a'.+inFree' :: (AllVars' a, FreeVars' b) => a -> b -> Set OccName+inFree' a b = free' aa ^+ (freeVars' b ^- bound' aa)+ where aa = allVars' a++-- `inVars' a b` is a value of `Vars_'` with bound variables the union+-- of the bound variables of 'a' and 'b' and free variables the union+-- of the free variables of 'a' and the free variables of 'b' not+-- bound by 'a'.+inVars' :: (AllVars' a, AllVars' b) => a -> b -> Vars'+inVars' a b =+ Vars' (bound' aa ^+ bound' bb) (free' aa ^+ (free' bb ^- bound' aa))+ where aa = allVars' a+ bb = allVars' b++-- Get an `OccName` out of a reader name.+unqualNames' :: Located RdrName -> [OccName]+unqualNames' (dL -> L _ (Unqual x)) = [x]+unqualNames' (dL -> L _ (Exact x)) = [nameOccName x]+unqualNames' _ = []++instance FreeVars' (LHsExpr GhcPs) where+ freeVars' (dL -> L _ (HsVar _ x)) = Set.fromList $ unqualNames' x -- Variable.+ freeVars' (dL -> L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes".+ freeVars' (dL -> L _ (HsLam _ MG{mg_alts=(dL -> L _ ms)})) = free' (allVars' ms) -- Lambda abstraction. Currently always a single match.+ freeVars' (dL -> L _ (HsLamCase _ MG{mg_alts=(dL -> L _ ms)})) = free' (allVars' ms) -- Lambda-case.+ freeVars' (dL -> L _ (HsCase _ of_ MG{mg_alts=(dL -> L _ ms)})) = freeVars' of_ ^+ free' (allVars' ms) -- Case expr.+ freeVars' (dL -> L _ (HsLet _ binds e)) = inFree' binds e -- Let (rec).+ freeVars' (dL -> L _ (HsDo _ ctxt (dL -> L _ stmts))) = free' (allVars' stmts) -- Do block.+ freeVars' (dL -> L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars' flds -- Record construction.+ freeVars' (dL -> L _ (RecordUpd _ e flds)) = Set.unions $ freeVars' e : map freeVars' flds -- Record update.+ freeVars' (dL -> L _ (HsMultiIf _ grhss)) = free' (allVars' grhss) -- Multi-way if.++ freeVars' (dL -> L _ HsConLikeOut{}) = mempty -- After typechecker.+ freeVars' (dL -> L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.+ freeVars' (dL -> L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope 'fromLabel'.+ freeVars' (dL -> L _ HsIPVar{}) = mempty -- Implicit parameter.+ freeVars' (dL -> L _ HsOverLit{}) = mempty -- Overloaded literal.+ freeVars' (dL -> L _ HsLit{}) = mempty -- Simple literal.+ freeVars' (dL -> L _ HsRnBracketOut{}) = mempty -- Renamer produces these.+ freeVars' (dL -> L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.+ freeVars' (dL -> L _ HsWrap{}) = mempty -- Typechecker output.++ -- freeVars' (dL -> e@(L _ HsAppType{})) = freeVars' $ children e -- Visible type application e.g. 'f @ Int x y'.+ -- freeVars' (dL -> e@(L _ HsApp{})) = freeVars' $ children e -- Application.+ -- freeVars' (dL -> e@(L _ OpApp{})) = freeVars' $ children e -- Operator application.+ -- freeVars' (dL -> e@(L _ NegApp{})) = freeVars' $ children e -- Negation operator.+ -- freeVars' (dL -> e@(L _ HsPar{})) = freeVars' $ children e -- Parenthesized expr.+ -- freeVars' (dL -> e@(L _ SectionL{})) = freeVars' $ children e -- Left section.+ -- freeVars' (dL -> e@(L _ SectionR{})) = freeVars' $ children e -- Right section.+ -- freeVars' (dL -> e@(L _ ExplicitTuple{})) = freeVars' $ children e -- Explicit tuple and sections thereof.+ -- freeVars' (dL -> e@(L _ ExplicitSum{})) = freeVars' $ children e -- Used for unboxed sum types.+ -- freeVars' (dL -> e@(L _ HsIf{})) = freeVars' $ children e -- If.+ -- freeVars' (dL -> e@(L _ ExplicitList{})) = freeVars' $ children e -- Syntactic list e.g. '[a, b, c]'.+ -- freeVars' (dL -> e@(L _ ExprWithTySig{})) = freeVars' $ children e -- Expr with type signature.+ -- freeVars' (dL -> e@(L _ ArithSeq {})) = freeVars' $ children e -- Arithmetic sequence.+ -- freeVars' (dL -> e@(L _ HsSCC{})) = freeVars' $ children e -- Set cost center pragma (expr whose const is to be measured).+ -- freeVars' (dL -> e@(L _ HsCoreAnn{})) = freeVars' $ children e -- Pragma.+ -- freeVars' (dL -> e@(L _ HsBracket{})) = freeVars' $ children e -- Haskell bracket.+ -- freeVars' (dL -> e@(L _ HsSpliceE{})) = freeVars' $ children e -- Template haskell splice expr.+ -- freeVars' (dL -> e@(L _ HsProc{})) = freeVars' $ children e -- Proc notation for arrows.+ -- freeVars' (dL -> e@(L _ HsStatic{})) = freeVars' $ children e -- Static pointers extension.+ -- freeVars' (dL -> e@(L _ HsArrApp{})) = freeVars' $ children e -- Arrow tail or arrow application.+ -- freeVars' (dL -> e@(L _ HsArrForm{})) = freeVars' $ children e -- Come back to it. Arrow tail or arrow application.+ -- freeVars' (dL -> e@(L _ HsTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+ -- freeVars' (dL -> e@(L _ HsBinTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+ -- freeVars' (dL -> e@(L _ HsTickPragma{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+ -- freeVars' (dL -> e@(L _ EAsPat{})) = freeVars' $ children e -- Expr as pat.+ -- freeVars' (dL -> e@(L _ EViewPat{})) = freeVars' $ children e -- View pattern.+ -- freeVars' (dL -> e@(L _ ELazyPat{})) = freeVars' $ children e -- Lazy pattern.++ freeVars' e = freeVars' $ children e++instance FreeVars' (LHsRecField GhcPs (LHsExpr GhcPs)) where+ freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x++instance FreeVars' (LHsRecUpdField GhcPs) where+ freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x++instance AllVars' (LPat GhcPs) where+ allVars' (VarPat _ (dL -> L _ x)) = Vars' (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.+ allVars' (AsPat _ n x) = allVars' (VarPat noExt n :: Pat GhcPs) <> allVars' x -- As pattern.+ allVars' (ConPatIn _ (RecCon (HsRecFields flds _))) = allVars' flds+ allVars' (NPlusKPat _ n _ _ _ _) = allVars' (VarPat noExt n :: Pat GhcPs) -- n+k pattern.+ allVars' (ViewPat _ e p) = freeVars_' e <> allVars' p -- View pattern.++ allVars' WildPat{} = mempty -- Wildcard pattern.+ allVars' ConPatOut{} = mempty -- Renamer/typechecker.+ allVars' LitPat{} = mempty -- Literal pattern.+ allVars' NPat{} = mempty -- Natural pattern.++ -- allVars' p@SplicePat{} = allVars' $ children p -- Splice pattern (includes quasi-quotes).+ -- allVars' p@SigPat{} = allVars' $ children p -- Pattern with a type signature.+ -- allVars' p@CoPat{} = allVars' $ children p -- Coercion pattern.+ -- allVars' p@LazyPat{} = allVars' $ children p -- Lazy pattern.+ -- allVars' p@ParPat{} = allVars' $ children p -- Parenthesized pattern.+ -- allVars' p@BangPat{} = allVars' $ children p -- Bang pattern.+ -- allVars' p@ListPat{} = allVars' $ children p -- Syntactic list.+ -- allVars' p@TuplePat{} = allVars' $ children p -- Tuple sub patterns.+ -- allVars' p@SumPat{} = allVars' $ children p -- Anonymous sum pattern.++ allVars' p = allVars' $ children p++instance AllVars' (LHsRecField GhcPs (LPat GhcPs)) where+ allVars' (dL -> L _ (HsRecField _ x _)) = allVars' x++instance AllVars' (LStmt GhcPs (LHsExpr GhcPs)) where+ allVars' (dL -> L _ (LastStmt _ expr _ _)) = freeVars_' expr -- The last stmt of a 'ListComp', 'MonadComp', 'DoExpr','MDoExpr'.+ allVars' (dL -> L _ (BindStmt _ pat expr _ _)) = allVars' pat <> freeVars_' expr -- A generator e.g. 'x <- [1, 2, 3]'.+ allVars' (dL -> L _ (BodyStmt _ expr _ _)) = freeVars_' expr -- A boolean guard e.g. 'even x'.+ allVars' (dL -> L _ (LetStmt _ binds)) = allVars' binds -- A local declaration e.g. 'let y = x + 1'+ allVars' (dL -> L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars' stmts <> freeVars_' using <> maybe mempty freeVars_' by <> freeVars_' (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.+ allVars' (dL -> L _ (RecStmt _ stmts _ _ _ _ _)) = allVars' stmts -- A recursive binding for a group of arrows.++ allVars' (dL -> L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.+ allVars' (dL -> L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it.++ allVars' _ = mempty -- New ctor.++instance AllVars' (LHsLocalBinds GhcPs) where+ allVars' (dL -> L _ (HsValBinds _ (ValBinds _ binds _))) = allVars' (bagToList binds) -- Value bindings.+ allVars' (dL -> L _ (HsIPBinds _ (IPBinds _ binds))) = allVars' binds -- Implicit parameter bindings.++ allVars' (dL -> L _ EmptyLocalBinds{}) = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).++ allVars' _ = mempty -- New ctor.++instance AllVars' (LIPBind GhcPs) where+ allVars' (dL -> L _ (IPBind _ _ e)) = freeVars_' e++ allVars' _ = mempty -- New ctor.++instance AllVars' (LHsBind GhcPs) where+ allVars' (dL -> L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(dL -> L _ ms)}}) = allVars' (VarPat noExt n :: Pat GhcPs) <> allVars' ms -- Function bindings and simple variable bindings e.g. 'f x = e', 'f !x = 3', 'f = e', '!x = e', 'x `f` y = e'+ allVars' (dL -> L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars' n <> allVars' grhss -- Ctor patterns and some other interesting cases e.g. 'Just x = e', '(x) = e', 'x :: Ty = e'.++ allVars' (dL -> L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.+ allVars' (dL -> L _ VarBind{}) = mempty -- Typechecker.+ allVars' (dL -> L _ AbsBinds{}) = mempty -- Not sure but I think renamer.++ allVars' _ = mempty -- New ctor.++instance AllVars' (LMatch GhcPs (LHsExpr GhcPs)) where+ allVars' (dL -> L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars' (VarPat noExt name :: Pat GhcPs) <> allVars' pats <> allVars' grhss -- A pattern matching on an argument of a function binding.+ allVars' (dL -> L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars' ctxt <> allVars' pats <> allVars' grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.+ allVars' (dL -> L _ (Match _ _ pats grhss)) = allVars' pats <> allVars' grhss -- Everything else.++ allVars' _ = mempty -- New ctor.++instance AllVars' (HsStmtContext RdrName) where+ allVars' (PatGuard FunRhs{mc_fun=n}) = allVars' (VarPat noExt n :: Pat GhcPs)+ allVars' ParStmtCtxt{} = mempty -- Come back to it.+ allVars' TransStmtCtxt{} = mempty -- Come back to it.++ allVars' _ = mempty -- Everything else (correct).++instance AllVars' (GRHSs GhcPs (LHsExpr GhcPs)) where+ allVars' (GRHSs _ grhss binds) = inVars' binds (mconcat (map allVars' grhss))++ allVars' _ = mempty -- New ctor.++instance AllVars' (LGRHS GhcPs (LHsExpr GhcPs)) where+ allVars' (dL -> L _ (GRHS _ guards expr)) = let gs = allVars' guards in Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs))++ allVars' _ = mempty -- New ctor.++instance AllVars' (LHsDecl GhcPs) where+ allVars' (dL -> L l (ValD _ bind)) = allVars' (cL l bind :: LHsBind GhcPs)++ allVars' _ = mempty -- We only consider value bindings.++--++vars' :: FreeVars' a => a -> [String]+vars' = Set.toList . Set.map occNameString . freeVars'++varss' :: AllVars' a => a -> [String]+varss' = Set.toList . Set.map occNameString . free' . allVars'++pvars' :: AllVars' a => a -> [String]+pvars' = Set.toList . Set.map occNameString . bound' . allVars'++freeVarSet' :: FreeVars' a => a -> Set String+freeVarSet' = Set.map occNameString . freeVars'
+ src/GHC/Util/HsDecl.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE NamedFieldPuns #-}++module GHC.Util.HsDecl (declName,isForD') where++import HsSyn+import OccName+import SrcLoc++isForD' :: LHsDecl GhcPs -> Bool+isForD' (LL _ ForD{}) = True; isForD' _ = False++-- | @declName x@ returns the \"new name\" that is created (for+-- example a function declaration) by @x@. If @x@ isn't a declaration+-- that creates a new name (for example an instance declaration),+-- 'Nothing' is returned instead. This is useful because we don't+-- want to tell users to rename binders that they aren't creating+-- right now and therefore usually cannot change.+declName :: HsDecl GhcPs -> Maybe String+declName x = occNameString . occName <$> case x of+ TyClD _ FamDecl{tcdFam=FamilyDecl{fdLName}} -> Just $ unLoc fdLName+ TyClD _ SynDecl{tcdLName} -> Just $ unLoc tcdLName+ TyClD _ DataDecl{tcdLName} -> Just $ unLoc tcdLName+ TyClD _ ClassDecl{tcdLName} -> Just $ unLoc tcdLName+ ValD _ FunBind{fun_id} -> Just $ unLoc fun_id+ ValD _ VarBind{var_id} -> Just var_id+ ValD _ (PatSynBind _ PSB{psb_id}) -> Just $ unLoc psb_id+ SigD _ (TypeSig _ (x:_) _) -> Just $ unLoc x+ SigD _ (PatSynSig _ (x:_) _) -> Just $ unLoc x+ SigD _ (ClassOpSig _ _ (x:_) _) -> Just $ unLoc x+ ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name+ ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name+ _ -> Nothing
+ src/GHC/Util/HsExpr.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++-- Keep until 'isDotApp', 'descendApps', 'transformApps' and+-- 'allowLeftSection' are used.+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module GHC.Util.HsExpr (+ noSyntaxExpr'+ , isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isReturn'+ , dotApp'+ , simplifyExp', niceLambda', niceDotApp'+ , Brackets'(..)+ , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps'+ , varToStr', strToVar'+ , paren', fromChar'+) where++import HsSyn+import BasicTypes+import SrcLoc+import FastString+import RdrName+import OccName+import Bag(bagToList)+import TysWiredIn+import TcEvidence+import Name++import GHC.Util.Brackets+import GHC.Util.View+import GHC.Util.FreeVars+import GHC.Util.W+import GHC.Util.Pat++import Control.Applicative+import Control.Monad.Trans.State++import Data.Data+import Data.Generics.Uniplate.Data+import Data.List.Extra++import Refact.Types hiding (Match)+import qualified Refact.Types as R (SrcSpan)++--++noSyntaxExpr' :: SyntaxExpr GhcPs+noSyntaxExpr' =+ SyntaxExpr+ (HsLit noExt+ (HsString NoSourceText (fsLit "noSyntaxExpr")))+ [] WpHole++-- | 'dotApp a b' makes 'a . b'.+dotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+dotApp' x y = noLoc $ OpApp noExt x (noLoc $ HsVar noExt (noLoc $ mkVarUnqual (fsLit "."))) y++-- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.+paren' :: LHsExpr GhcPs -> LHsExpr GhcPs+paren' x+ | isAtom' x = x+ | otherwise = addParen' x++isVar',isReturn',isLexeme',isDotApp',isRecUpdate',isRecConstr',isDol', isDot' :: LHsExpr GhcPs -> Bool+isPar' (LL _ HsPar{}) = True; isPar' _ = False+isVar' (LL _ HsVar{}) = True; isVar' _ = False+isDot' (LL _ (HsVar _ (LL _ ident))) = occNameString (rdrNameOcc ident) == "."; isDot' _ = False+isDol' (LL _ (HsVar _ (L _ ident))) = occNameString (rdrNameOcc ident) == "$"; isDol' _ = False+isRecConstr' (LL _ RecordCon{}) = True; isRecConstr' _ = False+isRecUpdate' (LL _ RecordUpd{}) = True; isRecUpdate' _ = False+isDotApp' (LL _ (OpApp _ _ op _)) = isDot' op; isDotApp' _ = False+isLexeme' (LL _ HsVar{}) = True;isLexeme' (LL _ HsOverLit{}) = True;isLexeme' (LL _ HsLit{}) = True;isLexeme' _ = False+-- Allow both 'pure' and 'return' as they have the same semantics.+isReturn' (LL _ (HsVar _ (LL _ (Unqual x)))) = occNameString x == "return" || occNameString x == "pure"; isReturn' _ = False++--++apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs+apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y)++fromApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]+fromApps' (LL _ (HsApp _ x y)) = fromApps' x ++ [y]+fromApps' x = [x]++childrenApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]+childrenApps' (LL _ (HsApp _ x y)) = childrenApps' x ++ [y]+childrenApps' x = children x++universeApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]+universeApps' x = x : concatMap universeApps' (childrenApps' x)++descendApps' :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs+descendApps' f (LL l (HsApp _ x y)) = LL l $ HsApp noExt (descendApps' f x) (f y)+descendApps' f x = descend f x++descendAppsM' :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)+descendAppsM' f (LL l (HsApp _ x y)) = liftA2 (\x y -> LL l $ HsApp noExt x y) (descendAppsM' f x) (f y)+descendAppsM' f x = descendM f x++transformApps' :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs+transformApps' f = f . descendApps' (transformApps' f)++transformAppsM' :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)+transformAppsM' f x = f =<< descendAppsM' (transformAppsM' f) x++descendIndex' :: Data a => (Int -> a -> a) -> a -> a+descendIndex' f x = flip evalState 0 $ flip descendM x $ \y -> do+ i <- get+ modify (+1)+ return $ f i y++-- There are differences in pretty-printing between GHC and HSE. This+-- version never removes brackets.+descendBracket' :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs+descendBracket' op x = descendIndex' g x+ where+ g i y = if a then f i b else b+ where (a, b) = op y+ f i y@(LL _ e) | needBracket' i x y = addParen' y+ f _ y = y++-- Add brackets as suggested 'needBracket' at 1-level of depth.+rebracket1' :: LHsExpr GhcPs -> LHsExpr GhcPs+rebracket1' = descendBracket' (True, )++-- A list of application, with any necessary brackets.+appsBracket' :: [LHsExpr GhcPs] -> LHsExpr GhcPs+appsBracket' = foldl1 mkApp+ where mkApp x y = rebracket1' (noLoc $ HsApp noExt x y)++--++varToStr' :: LHsExpr GhcPs -> String+varToStr' (LL _ (HsVar _ (L _ n)))+ | n == consDataCon_RDR = ":"+ | n == nameRdrName nilDataConName = "[]"+ | n == nameRdrName (getName (tupleDataCon Boxed 0)) = "()"+ | otherwise = occNameString (rdrNameOcc n)+varToStr' _ = ""++strToVar' :: String -> LHsExpr GhcPs+strToVar' x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x))++--++simplifyExp' :: LHsExpr GhcPs -> LHsExpr GhcPs+-- Replace appliciations 'f $ x' with 'f (x)'.+simplifyExp' (LL l (OpApp _ x op y)) | isDol' op = LL l (HsApp noExt x (noLoc (HsPar noExt y)))+simplifyExp' e@(LL _ (HsLet _ (LL _ (HsValBinds _ (ValBinds _ binds []))) z)) =+ -- An expression of the form, 'let x = y in z'.+ case bagToList binds of+ [LL _ (FunBind _ _(MG _ (LL _ [LL _ (Match _(FunRhs (LL _ x) _ _) [] (GRHSs _[LL _ (GRHS _ [] y)] (LL _ (EmptyLocalBinds _))))]) _) _ _)]+ -- If 'x' is not in the free variables of 'y', beta-reduce to+ -- 'z[(y)/x]'.+ | occNameString (rdrNameOcc x) `notElem` vars' y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->+ transform f z+ where f (view' -> Var_' x') | occNameString (rdrNameOcc x) == x' = paren' y+ f x = x+ _ -> e+simplifyExp' e = e++-- ($) . b ==> b+niceDotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+niceDotApp' (LL _ (HsVar _ (L _ r))) b | occNameString (rdrNameOcc r) == "$" = b+niceDotApp' a b = dotApp' a b++--+-- Generate a lambda expression but prettier if possible.+niceLambda' :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs+niceLambda' ss e = fst (niceLambdaR' ss e)-- We don't support refactorings yet.++allowRightSection x = x `notElem` ["-","#"]+allowLeftSection x = x /= "#"++-- Implementation. Try to produce special forms (e.g. sections,+-- compositions) where we can.+niceLambdaR' :: [String]+ -> LHsExpr GhcPs+ -> (LHsExpr GhcPs, R.SrcSpan+ -> [Refactoring R.SrcSpan])+-- Rewrite '\xs -> (e)' as '\xs -> e'.+niceLambdaR' xs (LL _ (HsPar _ x)) = niceLambdaR' xs x+-- Rewrite '\x -> x + a' as '(+ a)' (heuristic: 'a' must be a single+-- lexeme, or it all gets too complex).+niceLambdaR' [x] (view' -> App2' op@(LL _ (HsVar _ (L _ tag))) l r)+ | isLexeme' r, view' l == Var_' x, x `notElem` vars' r, allowRightSection (occNameString $ rdrNameOcc tag) =+ let e = rebracket1' $ addParen' (noLoc $ SectionR noExt op r)+ in (e, const [])+-- Rewrite (1) '\x -> f (b x)' as 'f . b', (2) '\x -> f $ b x' as 'f . b'.+niceLambdaR' [x] y+ | Just (z, subts) <- factor y, x `notElem` vars' z = (z, const [])+ where+ -- Factor the expression with respect to x.+ factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])+ factor y@(LL _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini])+ factor y@(LL _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst+ = let r = niceDotApp' ini z+ in if eqLoc' r z then Just (r, ss) else Just (r, ini : ss)+ factor (LL _ (OpApp _ y op (factor -> Just (z, ss))))| isDol' op+ = let r = niceDotApp' y z+ in if eqLoc' r z then Just (r, ss) else Just (r, y : ss)+ factor (LL _ (HsPar _ y@(LL _ HsApp{}))) = factor y+ factor _ = Nothing+-- Rewrite '\x y -> x + y' as '(+)'.+niceLambdaR' [x,y] (LL _ (OpApp _ (view' -> Var_' x1) op@(LL _ HsVar {}) (view' -> Var_' y1)))+ | x == x1, y == y1, vars' op `disjoint` [x, y] = (op, const [])+-- Rewrite '\x y -> f y x' as 'flip f'.+niceLambdaR' [x, y] (view' -> App2' op (view' -> Var_' y1) (view' -> Var_' x1))+ | x == x1, y == y1, vars' op `disjoint` [x, y] = (noLoc $ HsApp noExt (strToVar' "flip") op, const [])+-- Base case. Just a good old fashioned lambda.+niceLambdaR' ss e =+ let grhs = noLoc $ GRHS noExt [] e :: LGRHS GhcPs (LHsExpr GhcPs)+ grhss = GRHSs {grhssExt = noExt, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExt}+ match = noLoc $ Match {m_ext=noExt, m_ctxt=LambdaExpr, m_pats=map strToPat' ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)+ matchGroup = MG {mg_ext=noExt, mg_origin=Generated, mg_alts=noLoc [match]}+ in (noLoc $ HsLam noExt matchGroup, const [])++--++fromChar' :: LHsExpr GhcPs -> Maybe Char+fromChar' (LL _ (HsLit _ (HsChar _ x))) = Just x+fromChar' _ = Nothing
+ src/GHC/Util/HsType.hs view
@@ -0,0 +1,14 @@++module GHC.Util.HsType (+ Brackets'(..)+ , fromTyParen'+ ) where++import HsSyn+import SrcLoc++import GHC.Util.Brackets++fromTyParen' :: LHsType GhcPs -> LHsType GhcPs+fromTyParen' (LL _ (HsParTy _ x)) = x+fromTyParen' x = x
+ src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -0,0 +1,377 @@+-- Adapted from https://github.com/alanz/ghc-exactprint.git.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Util.Language.Haskell.GHC.ExactPrint.Types+ ( -- * Core Types+ Anns+ , emptyAnns+ , Annotation(..)+ , annNone++ , KeywordId(..)+ , Comment(..)+ -- * Positions+ , Pos+ , DeltaPos(..)+ , deltaRow, deltaColumn+ -- * AnnKey+ , AnnKey(..)+ , mkAnnKey+ , AnnConName(..)+ , annGetConstr++ -- * Other++ , Rigidity(..)+ , AstContext(..),AstContextSet,defaultACS+ , ACS'(..)+ , ListContexts(..)++ -- * For managing compatibility+ , Constraints++ -- * GHC version compatibility+ , GhcPs+ , GhcRn+ , GhcTc++ -- * Internal Types+ , LayoutStartCol(..)+ , declFun++ ) where++import Data.Data (Data, Typeable, toConstr,cast)++import qualified DynFlags as GHC+import qualified HsSyn as GHC+import qualified Outputable as GHC+import SrcLoc as GHC+import ApiAnnotation as GHC++import qualified Data.Map as Map+import qualified Data.Set as Set++-- ---------------------------------------------------------------------++type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)++-- ---------------------------------------------------------------------++-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted+-- from an @AnnKeywordId@ because the annotation must be interleaved into the+-- stream and does not have a well-defined position+data Comment = Comment+ {+ commentContents :: !String -- ^ The contents of the comment including separators++ -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is+ -- the thing we use to decide where in the output stream the comment should+ -- go.+ , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents+ , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.+ }+ deriving (Eq,Typeable,Data,Ord)+instance Show Comment where+ show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"++instance GHC.Outputable Comment where+ ppr x = GHC.text (show x)++type Pos = (Int,Int)++-- | A relative positions, row then column+newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)++deltaRow, deltaColumn :: DeltaPos -> Int+deltaRow (DP (r, _)) = r+deltaColumn (DP (_, c)) = c+++-- | Marks the start column of a layout block.+newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }+ deriving (Eq, Num)++instance Show LayoutStartCol where+ show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"+++annNone :: Annotation+annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing++data Annotation = Ann+ {+ -- The first three fields relate to interfacing up into the AST+ annEntryDelta :: !DeltaPos+ -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior+ -- output was, including all annPriorComments (field below).+ , annPriorComments :: ![(Comment, DeltaPos)]+ -- ^ Comments coming after the last non-comment output of the preceding+ -- element but before the SrcSpan being annotated by this Annotation. If+ -- these are changed then annEntryDelta (field above) must also change to+ -- match.+ , annFollowingComments :: ![(Comment, DeltaPos)]+ -- ^ Comments coming after the last output for the element subject to this+ -- Annotation. These will only be added by AST transformations, and care+ -- must be taken not to disturb layout of following elements.++ -- The next three fields relate to interacing down into the AST+ , annsDP :: ![(KeywordId, DeltaPos)]+ -- ^ Annotations associated with this element.+ , annSortKey :: !(Maybe [GHC.SrcSpan])+ -- ^ Captures the sort order of sub elements. This is needed when the+ -- sub-elements have been split (as in a HsLocalBind which holds separate+ -- binds and sigs) or for infix patterns where the order has been+ -- re-arranged. It is captured explicitly so that after the Delta phase a+ -- SrcSpan is used purely as an index into the annotations, allowing+ -- transformations of the AST including the introduction of new Located+ -- items or re-arranging existing ones.+ , annCapturedSpan :: !(Maybe AnnKey)+ -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of+ -- elements which we must remember for the Print phase. e.g. the statements+ -- in a HsLet or HsDo. These must be managed as a group because they all+ -- need eo be vertically aligned for the Haskell layout rules, and this+ -- guarantees this property in the presence of AST edits.++ } deriving (Typeable,Eq)++instance Show Annotation where+ show (Ann dp comments fcomments ans sk csp)+ = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "+ ++ show fcomments ++ " "+ ++ show ans ++ " " ++ showGhc sk ++ " "+ ++ showGhc csp ++ ")"+++-- | This structure holds a complete set of annotations for an AST+type Anns = Map.Map AnnKey Annotation++emptyAnns :: Anns+emptyAnns = Map.empty++-- | For every @Located a@, use the @SrcSpan@ and constructor name of+-- a as the key, to store the standard annotation.+-- These are used to maintain context in the AP and EP monads+data AnnKey = AnnKey GHC.SrcSpan AnnConName+ deriving (Eq, Ord, Data)++-- More compact Show instance+instance Show AnnKey where+ show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn+++mkAnnKeyPrim :: (Constraints a)+ => a -> AnnKey+mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a)++type GhcPs = GHC.GhcPs+type GhcRn = GHC.GhcRn+type GhcTc = GHC.GhcTc++-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.+mkAnnKey :: (Constraints a) => a -> AnnKey+mkAnnKey ld =+ case cast ld :: Maybe (GHC.LHsDecl GhcPs) of+ Just d -> declFun mkAnnKeyPrim d+ Nothing -> mkAnnKeyPrim ld++-- Holds the name of a constructor+data AnnConName = CN { unConName :: String }+ deriving (Eq, Ord, Data)++-- More compact show instance+instance Show AnnConName where+ show (CN s) = "CN " ++ show s++annGetConstr :: (Data a) => a -> AnnConName+annGetConstr a = CN (show $ toConstr a)++-- | The different syntactic elements which are not represented in the+-- AST.+data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword+ | AnnSemiSep -- ^ A separating comma+ | AnnTypeApp -- ^ Visible type application annotation+ | AnnComment Comment+ | AnnString String -- ^ Used to pass information from+ -- Delta to Print when we have to work+ -- out details from the original+ -- SrcSpan.+ deriving (Eq, Ord, Data)++instance Show KeywordId where+ show (G gc) = "(G " ++ show gc ++ ")"+ show AnnSemiSep = "AnnSemiSep"+ show AnnTypeApp = "AnnTypeApp"+ show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"+ show (AnnString s) = "(AnnString " ++ s ++ ")"++-- ---------------------------------------------------------------------++instance GHC.Outputable KeywordId where+ ppr k = GHC.text (show k)++instance GHC.Outputable AnnConName where+ ppr tr = GHC.text (show tr)++instance GHC.Outputable Annotation where+ ppr a = GHC.text (show a)++instance GHC.Outputable AnnKey where+ ppr a = GHC.text (show a)++instance GHC.Outputable DeltaPos where+ ppr a = GHC.text (show a)++-- ---------------------------------------------------------------------+--+-- Flag used to control whether we use rigid or normal layout rules.+-- NOTE: check is done via comparison of enumeration order, be careful with any changes+data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)+{-++Rigidity logic. The same type is used for two different things++1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies+ NormalLayout - Layout should be captured unconditionally++ RigidLayout - Layout should be captured or not depending on a parameter kept+ in the interpreter Read state++2. As the controlling parameter for the optional (Rigid) layout++The nett effect is the following, where flag is the hard-coded flag value in+Annotate, and param is the interpreter param set when the interpreter is run++ flag | param | result+ -------------+--------------+--------------------+ NormalLayout | either | layout captured+ RigidLayout | NormalLayout | layout NOT captured+ RigidLayout | RigidLayout | layout captured++The flag is only used on HsIf and HsCase++So++ state | HsCase | HsIf+ ----------------------------|-----------+------+ before rigidity flag (AZ) | no layout | layout+ param NormalLayout | no layout | no layout+ param RigidLayout | layout | layout+ ----------------------------+-----------+-------+ desired future HaRe | no layout | layout+ desired future apply-refact | layout | layout+-}++-- ---------------------------------------------------------------------++data ACS' a = ACS+ { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should+ -- propagate down the AST. Removed when it hits zero+ } deriving (Show)++instance Semigroup (ACS' AstContext) where+ (<>) = mappend++instance Monoid (ACS' AstContext) where+ mempty = ACS mempty+ -- ACS a `mappend` ACS b = ACS (a `mappend` b)+ ACS a `mappend` ACS b = ACS (Map.unionWith max a b)+ -- For Data.Map, mappend == union, which is a left-biased replace for key collisions++type AstContextSet = ACS' AstContext+-- data AstContextSet = ACS+-- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should+-- -- propagate down the AST. Removed when it+-- -- hits zero+-- } deriving (Show)++defaultACS :: AstContextSet+defaultACS = ACS Map.empty++-- instance GHC.Outputable AstContextSet where+instance (Show a) => GHC.Outputable (ACS' a) where+ ppr x = GHC.text $ show x++data AstContext = LambdaExpr+ | CaseAlt+ | NoPrecedingSpace+ | HasHiding+ | AdvanceLine+ | NoAdvanceLine+ | Intercalate -- This item may have a list separator following+ | InIE -- possible 'type' or 'pattern'+ | PrefixOp+ | PrefixOpDollar+ | InfixOp -- RdrName may be used as an infix operator+ | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently+ | ListItem -- Identifies subsequent elements of a list in layout+ | TopLevel -- top level declaration+ | NoDarrow+ | AddVbar+ | Deriving+ | Parens -- TODO: Not currently used?+ | ExplicitNeverActive+ | InGadt+ | InRecCon+ | InClassDecl+ | InSpliceDecl+ | LeftMost -- Is this the leftmost operator in a chain of OpApps?+ | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt+ -- TODO:AZ: do we actually need this?++ -- Next four used to identify current list context+ | CtxOnly+ | CtxFirst+ | CtxMiddle+ | CtxLast+ | CtxPos Int -- 0 for first, increasing for subsequent++ -- Next are used in tellContext to push context up the tree+ | FollowingLine+ deriving (Eq, Ord, Show)+++data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) }+ deriving (Eq,Show)++-- ---------------------------------------------------------------------++-- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD+-- -- should not have blank lines after it+-- deriving (Eq, Ord, Show)++-- ---------------------------------------------------------------------++declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b++declFun f (GHC.L l de) =+ case de of+ GHC.TyClD _ d -> f (GHC.L l d)+ GHC.InstD _ d -> f (GHC.L l d)+ GHC.DerivD _ d -> f (GHC.L l d)+ GHC.ValD _ d -> f (GHC.L l d)+ GHC.SigD _ d -> f (GHC.L l d)+ GHC.DefD _ d -> f (GHC.L l d)+ GHC.ForD _ d -> f (GHC.L l d)+ GHC.WarningD _ d -> f (GHC.L l d)+ GHC.AnnD _ d -> f (GHC.L l d)+ GHC.RuleD _ d -> f (GHC.L l d)+ GHC.SpliceD _ d -> f (GHC.L l d)+ GHC.DocD _ d -> f (GHC.L l d)+ GHC.RoleAnnotD _ d -> f (GHC.L l d)+ GHC.XHsDecl d -> f (GHC.L l d)++-- ---------------------------------------------------------------------++-- Duplicated here so it can be used in show instances+showGhc :: (GHC.Outputable a) => a -> String+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags++-- ---------------------------------------------------------------------
+ src/GHC/Util/LanguageExtensions/Type.hs view
@@ -0,0 +1,13 @@++module GHC.Util.LanguageExtensions.Type (+ readExtension+) where++import GHC.LanguageExtensions.Type++import qualified Data.Map.Strict as Map++-- | Parse a GHC extension+readExtension :: String -> Maybe Extension+readExtension x = Map.lookup x exts+ where exts = Map.fromList [(show x, x) | x <- [Cpp .. StarIsType]]
+ src/GHC/Util/Module.hs view
@@ -0,0 +1,11 @@++module GHC.Util.Module (modName) where++import HsSyn+import Module+import SrcLoc++modName :: Located (HsModule GhcPs) -> String+modName (LL _ HsModule {hsmodName=Nothing}) = "Main"+modName (LL _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n+modName _ = "" -- {-# COMPLETE LL #-}
+ src/GHC/Util/Outputable.hs view
@@ -0,0 +1,14 @@++module GHC.Util.Outputable (unsafePrettyPrint) where++import Outputable++-- \"Unsafe\" 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
+ src/GHC/Util/Pat.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}++module GHC.Util.Pat (+ strToPat', patToStr'+ , Brackets'(..)+ , fromPChar', isPFieldWildcard', hasPFieldsDotDot'+ ) where++import HsSyn+import SrcLoc+import TysWiredIn+import FastString+import RdrName++import GHC.Util.Brackets++patToStr' :: Pat GhcPs -> String+patToStr' (LL _ (ConPatIn (L _ x) (PrefixCon []))) | x == true_RDR = "True"+patToStr' (LL _ (ConPatIn (L _ x) (PrefixCon []))) | x == false_RDR = "False"+patToStr' (LL _ (ConPatIn (L _ x) (PrefixCon []))) | x == nameRdrName nilDataConName = "[]"+patToStr' _ = ""++strToPat' :: String -> Pat GhcPs+strToPat' z+ | z == "True" = ConPatIn (noLoc true_RDR) (PrefixCon [])+ | z == "False" = ConPatIn (noLoc false_RDR) (PrefixCon [])+ | z == "[]" = ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon [])+ | otherwise = VarPat noExt (noLoc $ mkVarUnqual (fsLit z))++fromPChar' :: Pat GhcPs -> Maybe Char+fromPChar' (LL _ (LitPat _ (HsChar _ x))) = Just x+fromPChar' _ = Nothing++-- Contains a '..' as in 'Foo{..}'+hasPFieldsDotDot' :: HsRecFields GhcPs (Pat GhcPs) -> Bool+hasPFieldsDotDot' HsRecFields {rec_dotdot=Just _} = True+hasPFieldsDotDot' _ = False -- {-# COMPLETE LL #-}++-- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'.+isPFieldWildcard' :: LHsRecField GhcPs (Pat GhcPs) -> Bool+isPFieldWildcard' (LL _ HsRecField {hsRecFieldArg=(LL _ (WildPat _))}) = True+isPFieldWildcard' (LL _ HsRecField {hsRecPun=True}) = True+isPFieldWildcard' (LL _ HsRecField {}) = False+isPFieldWildcard' _ = False -- {-# COMPLETE LL #-}
+ src/GHC/Util/Refact/Fixity.hs view
@@ -0,0 +1,204 @@+-- Adapted from https://github.com/mpickering/apply-refact.git.++{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+module GHC.Util.Refact.Fixity (applyFixities) where++import SrcLoc++import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..))+import HsExpr+import HsPat+import HsTypes+import RdrName+import HsExtension+import OccName+import Data.Generics hiding (Fixity)+import Data.Maybe++import GHC.Util.Refact.Utils+import GHC.Util.Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn)++import Control.Monad.State+import qualified Data.Map as Map+import Data.Tuple++-- | Rearrange infix expressions to account for fixity.+-- The set of fixities is wired in and includes all fixities in base.+applyFixities :: Anns -> [(String, Fixity)] -> Module -> (Anns, Module)+applyFixities as fixities m = let (as', m') = swap $ runState (everywhereM (mkM (expFix fixities)) m) as+ (as'', m'') = swap $ runState (everywhereM (mkM (patFix fixities)) m') as'+ in (as'', m'') --error (showAnnData as 0 m ++ showAnnData as' 0 m')++getFixities fixities =+ if null fixities then baseFixities else fixities++expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> M (LHsExpr GhcPs)+expFix fixities (L loc (OpApp _ l op r)) =+ mkOpAppRn (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r++expFix _ e = return e++patFix :: [(String, Fixity)] -> LPat GhcPs -> M (LPat GhcPs)+patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) =+ mkConOpPatRn (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2++patFix _ p = return p++getIdent :: Expr -> String+getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n+getIdent _ = error "Must be HsVar"+++moveDelta :: AnnKey -> AnnKey -> M ()+moveDelta old new = do+ a@Ann{..} <- gets (fromMaybe annNone . Map.lookup old)+ modify (Map.insert new (annNone { annEntryDelta = annEntryDelta, annPriorComments = annPriorComments }))+ modify (Map.insert old (a { annEntryDelta = DP (0,0), annPriorComments = []}))++---------------------------+-- Modified from GHC Renamer++mkConOpPatRn ::+ [(String, Fixity)]+ -> Located RdrName -> Fixity -- Operator and fixity+ -> LPat GhcPs+ -> LPat GhcPs+ -> M (LPat GhcPs)+mkConOpPatRn fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2+ | nofix_error+ = return (ConPatIn op2 (InfixCon p1 p2))++ | associate_right = do+ new_p <- mkConOpPatRn fs op2 fix2 p12 p2+ return (ConPatIn op1 (InfixCon p11 (cL loc new_p)))++ | otherwise = return (ConPatIn op2 (InfixCon p1 p2))++ where+ fix1 = findFixity' fs op1+ (nofix_error, associate_right) = compareFixity fix1 fix2++mkConOpPatRn _ op _ p1 p2 -- Default case, no rearrangment+ = return (ConPatIn op (InfixCon p1 p2))++mkOpAppRn ::+ [(String, Fixity)]+ -> SrcSpan+ -> LHsExpr GhcPs -- Left operand; already rearrange+ -> LHsExpr GhcPs -> Fixity -- Operator and fixity+ -> LHsExpr GhcPs -- Right operand (not an OpApp, but might+ -- be a NegApp)+ -> M (LHsExpr GhcPs)++-- (e11 `op1` e12) `op2` e2+mkOpAppRn fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2+ | nofix_error+ = return $ L loc (OpApp noExt e1 op2 e2)++ | associate_right = do+ new_e <- mkOpAppRn fs loc' e12 op2 fix2 e2+ moveDelta (mkAnnKey e12) (mkAnnKey new_e)+ return $ L loc (OpApp x1 e11 op1 new_e)+ where+ loc'= combineLocs e12 e2+ fix1 = findFixity fs op1+ (nofix_error, associate_right) = compareFixity fix1 fix2++---------------------------+-- (- neg_arg) `op` e2+mkOpAppRn fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+ | nofix_error+ = return (L loc (OpApp noExt e1 op2 e2))++ | associate_right+ = do+ new_e <- mkOpAppRn fs loc' neg_arg op2 fix2 e2+ moveDelta (mkAnnKey neg_arg) (mkAnnKey new_e)+ let res = L loc (NegApp noExt new_e neg_name)+ key = mkAnnKey res+ ak = AnnKey loc (CN "OpApp")+ opAnn <- gets (fromMaybe annNone . Map.lookup ak)+ negAnns <- gets (fromMaybe annNone . Map.lookup (mkAnnKey e1))+ modify (Map.insert key (annNone { annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns }))+ return res++ where+ loc' = combineLocs neg_arg e2+ (nofix_error, associate_right) = compareFixity negateFixity fix2++---------------------------+-- e1 `op` - neg_arg+mkOpAppRn _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right+ | not associate_right -- We *want* right association+ = return $ L loc (OpApp noExt e1 op1 e2)+ where+ (_, associate_right) = compareFixity fix1 negateFixity++---------------------------+-- Default case+mkOpAppRn _ loc e1 op _fix e2 -- Default case, no rearrangment+ = return $ L loc (OpApp noExt e1 op e2)++findFixity :: [(String, Fixity)] -> Expr -> Fixity+findFixity fs r = askFix fs (getIdent r)++findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity+findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r)++askFix :: [(String, Fixity)] -> String -> Fixity+askFix xs = \k -> lookupWithDefault defaultFixity k xs+ where+ lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1++-- | All fixities defined in the Prelude.+preludeFixities :: [(String, Fixity)]+preludeFixities = concat+ [infixr_ 9 ["."]+ ,infixl_ 9 ["!!"]+ ,infixr_ 8 ["^","^^","**"]+ ,infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"]+ ,infixl_ 6 ["+","-"]+ ,infixr_ 5 [":","++"]+ ,infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"]+ ,infixr_ 3 ["&&"]+ ,infixr_ 2 ["||"]+ ,infixl_ 1 [">>",">>="]+ ,infixr_ 1 ["=<<"]+ ,infixr_ 0 ["$","$!","seq"]+ ]++-- | All fixities defined in the base package.+--+-- Note that the @+++@ operator appears in both Control.Arrows and+-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in+-- this list is that of Control.Arrows.+baseFixities :: [(String, Fixity)]+baseFixities = preludeFixities ++ concat+ [infixl_ 9 ["!","//","!:"]+ ,infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"]+ ,infixl_ 7 [".&."]+ ,infixl_ 6 ["xor"]+ ,infix_ 6 [":+"]+ ,infixl_ 5 [".|."]+ ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow+ ,infix_ 5 ["\\\\"]+ ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"]+ ,infix_ 4 ["elemP","notElemP"]+ ,infixl_ 3 ["<|>"]+ ,infixr_ 3 ["&&&","***"]+ ,infixr_ 2 ["+++","|||"]+ ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]+ ,infixl_ 0 ["on"]+ ,infixr_ 0 ["par","pseq"]+ ]++infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)]+infixr_ = fixity InfixR+infixl_ = fixity InfixL+infix_ = fixity InfixN++-- Internal: help function for the above definitions.+fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]+fixity a p = map (,Fixity (SourceText "") p a)
+ src/GHC/Util/Refact/Utils.hs view
@@ -0,0 +1,166 @@+-- Adapted from https://github.com/mpickering/apply-refact.git.++{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Util.Refact.Utils ( -- * Synonyms+ Module+ , Stmt+ , Expr+ , Decl+ , Name+ , Pat+ , Type+ , Import+ , FunBind+ -- * Monad+ , M+ -- * Utility++ , mergeAnns+ , modifyAnnKey+ , replaceAnnKey+ , toGhcSrcSpan+ , findParent++ ) where++import HsSyn as GHC hiding (Stmt, Pat)+import SrcLoc+import qualified SrcLoc as GHC+import qualified RdrName as GHC+import qualified ApiAnnotation as GHC+import qualified FastString as GHC++import GHC.Util.Language.Haskell.GHC.ExactPrint.Types++import Data.Data++import Control.Monad.State++import qualified Data.Map as Map+import Data.Maybe+++import qualified Refact.Types as R++import Data.Generics.Schemes+import Unsafe.Coerce++-- | Left bias pair union+mergeAnns :: Anns -> Anns -> Anns+mergeAnns+ = Map.union++-- Types+--+type M a = State Anns a++type Module = (GHC.Located (GHC.HsModule GHC.GhcPs))++type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs)++type Type = GHC.Located (GHC.HsType GHC.GhcPs)++type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs)++type Pat = GHC.LPat GHC.GhcPs++type Name = GHC.Located GHC.RdrName++type Stmt = ExprLStmt GHC.GhcPs++type Import = LImportDecl GHC.GhcPs++type FunBind = HsMatchContext GHC.RdrName++-- | Replaces an old expression with a new expression+--+-- Note that usually, new, inp and parent are all the same.+replace :: AnnKey -- The thing we are replacing+ -> AnnKey -- The thing which has the annotations we need for the new thing+ -> AnnKey -- The thing which is going to be inserted+ -> AnnKey -- The "parent", the largest thing which has he same SrcSpan+ -- Usually the same as inp and new+ -> Anns -> Maybe Anns+replace old new inp parent anns = do+ oldan <- Map.lookup old anns+ newan <- Map.lookup new anns+ oldDelta <- annEntryDelta <$> Map.lookup parent anns+ return $ Map.insert inp (combine oldDelta oldan newan) anns++combine :: DeltaPos -> Annotation -> Annotation -> Annotation+combine oldDelta oldann newann =+ Ann { annEntryDelta = newEntryDelta+ , annPriorComments = annPriorComments oldann ++ annPriorComments newann+ , annFollowingComments = annFollowingComments oldann ++ annFollowingComments newann+ , annsDP = removeComma (annsDP newann) ++ extraComma (annsDP oldann)+ , annSortKey = annSortKey newann+ , annCapturedSpan = annCapturedSpan newann}+ where+ -- Get rid of structural information when replacing, we assume that the+ -- structural information is already there in the new expression.+ removeComma = filter (\(kw, _) -> case kw of+ G GHC.AnnComma -> False+ AnnSemiSep -> False+ _ -> True)++ -- Make sure to keep structural information in the template.+ extraComma [] = []+ extraComma (last -> x) = case fst x of+ G GHC.AnnComma -> [x]+ AnnSemiSep -> [x]+ G GHC.AnnSemi -> [x]+ _ -> []++ -- Keep the same delta if moving onto a new row+ newEntryDelta | deltaRow oldDelta > 0 = oldDelta+ | otherwise = annEntryDelta oldann+++-- | A parent in this case is an element which has the same SrcSpan+findParent :: Data a => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey+findParent ss as = something (findParentWorker ss as)++-- Note that a parent must also have an annotation.+findParentWorker :: forall a . (Data a)+ => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey+findParentWorker oldSS as a+ | con == typeRepTyCon (typeRep (Proxy :: Proxy (GHC.Located GHC.RdrName))) && x == typeRep (Proxy :: Proxy GHC.SrcSpan)+ = if ss == oldSS+ && isJust (Map.lookup (AnnKey ss cn) as)+ then Just $ AnnKey ss cn+ else Nothing+ | otherwise = Nothing+ where+ (con, ~[x, _]) = splitTyConApp (typeOf a)+ ss :: GHC.SrcSpan+ ss = gmapQi 0 unsafeCoerce a+ cn = gmapQi 1 (CN . show . toConstr) a+++-- | Perform the necessary adjustments to annotations when replacing+-- one Located thing with another Located thing.+--+-- For example, this function will ensure the correct relative position and+-- make sure that any trailing semi colons or commas are transferred.+modifyAnnKey :: (Data old, Data new, Data mod) => mod -> Located old -> Located new -> M (Located new)+modifyAnnKey m e1 e2 = do+ as <- get+ let parentKey = fromMaybe (mkAnnKey e2) (findParent (getLoc e2) as m)+ e2 <$ modify (\m' -> replaceAnnKey m' (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey)+++-- | Lower level version of @modifyAnnKey@+replaceAnnKey ::+ Anns -> AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns+replaceAnnKey a old new inp deltainfo =+ fromMaybe a (replace old new inp deltainfo a)+++-- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@+toGhcSrcSpan :: FilePath -> R.SrcSpan -> SrcSpan+toGhcSrcSpan file R.SrcSpan{..} = mkSrcSpan (f startLine startCol) (f endLine endCol)+ where+ f = mkSrcLoc (GHC.mkFastString file)
+ src/GHC/Util/SrcLoc.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.SrcLoc (+ stripLocs'+ , SrcSpanD(..)+ ) where++import SrcLoc+import Outputable++import Data.Default+import Data.Data+import Data.Generics.Uniplate.Data++-- 'stripLocs x' is 'x' with all contained source locs replaced by+-- 'noSrcSpan'.+stripLocs' :: (Data from, HasSrcSpan from) => from -> from+stripLocs' = transformBi (const noSrcSpan)++-- 'Duplicates.hs' requires 'SrcSpan' be in 'Default'.+newtype SrcSpanD = SrcSpanD SrcSpan+ deriving (Outputable, Eq, Ord)+instance Default SrcSpanD where def = SrcSpanD noSrcSpan
+ src/GHC/Util/View.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}++module GHC.Util.View (+ fromParen', fromPParen'+ , View'(..)+ , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2')+) where++import HsSyn+import SrcLoc+import RdrName+import OccName++fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen' (LL _ (HsPar _ x)) = fromParen' x+fromParen' x = x++fromPParen' :: Pat GhcPs -> Pat GhcPs+fromPParen' (LL _ (ParPat _ x)) = fromPParen' x+fromPParen' x = x++class View' a b where+ view' :: a -> b++data Var_' = NoVar_' | Var_' String deriving Eq+data PVar_' = NoPVar_' | PVar_' String+data PApp_' = NoPApp_' | PApp_' String [Pat GhcPs]+data App2' = NoApp2' | App2' (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)++instance View' (LHsExpr GhcPs) Var_' where+ view' (fromParen' -> (LL _ (HsVar _ (LL _ (Unqual x))))) = Var_' $ occNameString x+ view' _ = NoVar_'++instance View' (LHsExpr GhcPs) App2' where+ view' (fromParen' -> LL _ (OpApp _ lhs op rhs)) = App2' op lhs rhs+ view' (fromParen' -> LL _ (HsApp _ (LL _ (HsApp _ f x)) y)) = App2' f x y+ view' _ = NoApp2'++instance View' (Pat GhcPs) PVar_' where+ view' (fromPParen' -> LL _ (VarPat _ (L _ x))) = PVar_' $ occNameString (rdrNameOcc x)+ view' _ = NoPVar_'++instance View' (Pat GhcPs) PApp_' where+ view' (fromPParen' -> LL _ (ConPatIn (L _ x) (PrefixCon args))) =+ PApp_' (occNameString . rdrNameOcc $ x) args+ view' (fromPParen' -> LL _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =+ PApp_' (occNameString . rdrNameOcc $ x) [lhs, rhs]+ view' _ = NoPApp_'
+ src/GHC/Util/W.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.W (+ W(..)+ , wrap, unwrap+ , eqLoc', eqNoLoc', eqNoLocLists') where++import Outputable+import SrcLoc++import GHC.Util.DynFlags+import GHC.Util.SrcLoc++import Data.Function+import Data.Data+import Data.Generics.Uniplate.Data ()++newtype W a = W a deriving Outputable -- Wrapper of terms.+-- The issue is that at times, terms we work with in this program are+-- not in `Eq` and `Ord` and we need them to be. This work-around+-- resorts to implementing `Eq` and `Ord` for the these types via+-- lexicographical comparisons of string representations. As long as+-- two different terms never map to the same string representation,+-- basing `Eq` and `Ord` on their string representations rather than+-- the term types themselves, leads to identical results.+wToStr :: Outputable a => W a -> String+wToStr (W e) = showPpr baseDynFlags e+instance Outputable a => Eq (W a) where (==) a b = wToStr a == wToStr b+instance Outputable a => Ord (W a) where compare = compare `on` wToStr++wrap :: a -> W a+wrap = W++unwrap :: W a -> a+unwrap (W x) = x++-- Compare two terms for absolute equality.+eqLoc' :: Outputable a => a -> a -> Bool+eqLoc' a b = wrap a == wrap b++-- Compare two terms for equality modulo locs.+eqNoLoc' :: (Data a, Outputable a, HasSrcSpan a) => a -> a -> Bool+eqNoLoc' a b = wrap (stripLocs' a) == wrap (stripLocs' b)++eqNoLocLists' :: (Data a, Outputable a, HasSrcSpan a) => [a] -> [a] -> Bool+eqNoLocLists' as bs = length as == length bs && all (uncurry eqNoLoc') (zip as bs)
src/HSE/All.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TupleSections #-} module HSE.All( module X,@@ -33,15 +33,18 @@ import Data.Functor import Prelude +import qualified HsSyn+import qualified FastString+import qualified SrcLoc as GHC+import qualified ErrUtils+import qualified Outputable+import qualified Lexer as GHC+import qualified GHC.LanguageExtensions.Type as GHC+import qualified ApiAnnotation as GHC+import qualified BasicTypes as GHC+ import GHC.Util-import qualified "ghc-lib-parser" HsSyn-import qualified "ghc-lib-parser" FastString-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+import qualified GHC.Util.Refact.Fixity as GHC -- | Convert a GHC source loc into an HSE equivalent. ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc@@ -151,7 +154,7 @@ {fixities = Just $ customFixities ++ baseFixities ++ baseNotYetInHSE ++ lensFixities ++ otherFixities ,ignoreLinePragmas = False ,ignoreFunctionArity = True- ,extensions = defaultExtensions}+ ,extensions = parseExtensions} parseFlagsNoLocations :: ParseFlags -> ParseFlags parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y}@@ -189,12 +192,12 @@ data ModuleEx = ModuleEx { hseModule :: Module SrcSpanInfo , hseComments :: [Comment]- , ghcModule :: Located (HsSyn.HsModule HsSyn.GhcPs)+ , ghcModule :: GHC.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 :: ModuleEx -> [GHC.Located GHC.AnnotationComment] ghcComments m = concat (Map.elems $ snd (ghcAnnotations m)) -- | Utility called from 'parseModuleEx' and 'hseFailOpParseModuleEx'.@@ -274,6 +277,32 @@ UnknownExtension ('N':'o':e) -> Right <$> readExtension e UnknownExtension e -> Left <$> readExtension e +-- A hacky function to get fixities from HSE parse flags suitable for+-- use by our own 'GHC.Util.Refact.Fixity' module.+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]+ghcFixitiesFromParseFlags ParseFlags {hseFlags=ParseMode{fixities=Just fixities}} =+ concatMap convert fixities+ where+ convert (Fixity (AssocNone _) fix name) = infix_' fix [qNameToStr name]+ convert (Fixity (AssocLeft _) fix name) = infixl_' fix [qNameToStr name]+ convert (Fixity (AssocRight _) fix name) = infixr_' fix [qNameToStr name]++ infixr_', infixl_', infix_' :: Int -> [String] -> [(String,GHC.Fixity)]+ infixr_' = fixity' GHC.InfixR+ infixl_' = fixity' GHC.InfixL+ infix_' = fixity' GHC.InfixN++ fixity' :: GHC.FixityDirection -> Int -> [String] -> [(String, GHC.Fixity)]+ fixity' a p = map (,GHC.Fixity (GHC.SourceText "") p a)++ qNameToStr :: QName () -> String+ qNameToStr (Special _ Cons{}) = ":"+ qNameToStr (Special _ UnitCon{}) = "()"+ qNameToStr (UnQual _ (X.Ident _ x)) = x+ qNameToStr (UnQual _ (Symbol _ x)) = x+ qNameToStr _ = ""+ghcFixitiesFromParseFlags _ = []+ -- | Parse a Haskell module. Applies the C pre processor, and uses -- best-guess fixity resolution if there are ambiguities. The -- filename @-@ is treated as @stdin@. Requires some flags (often@@ -288,19 +317,21 @@ str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130 ppstr <- runCpp (cppFlags flags) file str let enableDisableExts = ghcExtensionsFromParseFlags flags+ fixities = ghcFixitiesFromParseFlags flags -- Note : Fixities are coming from HSE parse flags. dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr case dynFlags of Right ghcFlags -> case (parseFileContentsWithComments (mkMode flags file) ppstr, parseFileGhcLib file ppstr ghcFlags) of- (ParseOk (x, cs), POk pst a) ->+ (ParseOk (x, cs), GHC.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)+ let (_, a') = GHC.applyFixities Map.empty fixities a 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) ->+ (ParseOk _, GHC.PFailed _ loc err) -> ghcFailOpParseModuleEx ppstr file str (loc, err) (ParseFailed sl msg, pfailed) -> failOpParseModuleEx ppstr flags file str sl msg $ fromPFailed pfailed@@ -314,7 +345,7 @@ return $ Left (ParseError loc msg (context (srcLine loc) ppstr)) where- fromPFailed (PFailed _ loc err) = Just (loc, err)+ fromPFailed (GHC.PFailed _ loc err) = Just (loc, err) fromPFailed _ = Nothing fixity = fromMaybe [] $ fixities $ hseFlags flags
src/HSE/Match.hs view
@@ -3,7 +3,7 @@ module HSE.Match( View(..), Named(..), (~=), isSym,- App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_), PApp_(PApp_)+ App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_) ) where import Data.Char@@ -35,13 +35,6 @@ instance View Exp_ LamConst1 where view (fromParen -> Lambda _ [PWildCard _] x) = LamConst1 x view _ = NoLamConst1--data PApp_ = NoPApp_ | PApp_ String [Pat_]--instance View Pat_ PApp_ where- view (fromPParen -> PApp _ x xs) = PApp_ (fromNamed x) xs- view (fromPParen -> PInfixApp _ lhs op rhs) = PApp_ (fromNamed op) [lhs, rhs]- view _ = NoPApp_ data PVar_ = NoPVar_ | PVar_ String
src/HSE/Unify.hs view
@@ -102,7 +102,8 @@ -- in the match even if they aren't in the users code unifyExp nm root x y | not root, isParen x, not $ isParen y = unifyExp nm root (fromParen x) y -unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just $ Subst [(v,y)]+-- don't subsitute for type apps, since no one writes rules imaginging they exist+unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst [(v,y)] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just mempty -- Match wildcard operators
src/HSE/Util.hs view
@@ -398,7 +398,7 @@ extensionImplications :: [(Extension, [Extension])] extensionImplications = map (first EnableExtension) $ (RebindableSyntax, [DisableExtension ImplicitPrelude]) :- map (\(k, vs) -> (k, map EnableExtension vs))+ map (second (map EnableExtension)) [ (DerivingVia , [DerivingStrategies]) , (RecordWildCards , [DisambiguateRecordFields]) , (ExistentialQuantification, [ExplicitForAll])
src/Hint/All.hs view
@@ -44,23 +44,26 @@ builtin :: HintBuiltin -> Hint builtin x = case x of- HintList -> decl listHint- HintListRec -> decl listRecHint+ -- Hse.+ HintExtensions -> modu extensionsHint HintMonad -> decl monadHint HintLambda -> decl lambdaHint- HintBracket -> decl bracketHint- HintNaming -> decl' namingHint HintPattern -> decl patternHint++ -- Ghc. HintImport -> modu importHint HintExport -> modu exportHint HintComment -> modu commentHint HintPragma -> modu pragmaHint- HintExtensions -> modu extensionsHint- HintUnsafe -> decl unsafeHint HintDuplicate -> mods duplicateHint- HintNewType -> decl' newtypeHint HintRestrict -> mempty{hintModule=restrictHint}- HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}+ HintList -> decl' listHint+ HintNewType -> decl' newtypeHint+ HintUnsafe -> decl' unsafeHint+ HintListRec -> decl' listRecHint+ HintNaming -> decl' namingHint+ HintBracket -> decl' bracketHint+ 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}
src/Hint/Bracket.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} {--Raise an error if you are bracketing an atom, or are enclosed be a list bracket +Raise an error if you are bracketing an atom, or are enclosed by a+list bracket.+ <TEST> -- expression bracket reduction yes = (f x) x -- @Suggestion f x x@@ -85,31 +89,43 @@ module Hint.Bracket(bracketHint) where -import Hint.Type+import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',Severity(..),toSS') import Data.Data+import Data.Generics.Uniplate.Operations import Refact.Types +import HsSyn+import Outputable+import SrcLoc+import GHC.Util -bracketHint :: DeclHint+bracketHint :: DeclHint' bracketHint _ _ x =- concatMap (\x -> bracket isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [Exp_]) ++- concatMap (bracket (const False) False) (childrenBi x :: [Type_]) ++- concatMap (bracket (const False) False) (childrenBi x :: [Pat_]) ++- concatMap fieldDecl (childrenBi x)- where- -- Brackets at the roots of annotations are fine, so we strip them- annotations :: Annotation S -> Annotation S- annotations = descendBi $ \x -> case (x :: Exp_) of- Paren _ x -> x- x -> x+ concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) +++ concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LHsType GhcPs]) +++ concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [Pat GhcPs]) +++ concatMap fieldDecl (childrenBi x)+ where+ -- Brackets the roots of annotations are fine, so we strip them.+ annotations :: AnnDecl GhcPs -> AnnDecl GhcPs+ annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of+ LL l (HsPar _ x) -> x+ x -> x -isPartialAtom :: Exp_ -> Bool-isPartialAtom (SpliceExp _ IdSplice{}) = True -- might be $x, which was really $ x, but TH enabled misparsed it-isPartialAtom x = isRecConstr x || isRecUpdate x+-- If we find ourselves in the context of a section and we want to+-- issue a warning that a child therein has unneccessary brackets,+-- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found :+-- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the+-- latter (in contrast to the HSE pretty printer). This patches things+-- up.+prettyExpr :: LHsExpr GhcPs -> String+prettyExpr s@(LL _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExt s) :: LHsExpr GhcPs)+prettyExpr s@(LL _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExt s) :: LHsExpr GhcPs)+prettyExpr x = unsafePrettyPrint x -- Dirty, should add to Brackets type class I think tyConToRtype :: String -> RType-tyConToRtype "Exp" = Expr+tyConToRtype "Exp" = Expr tyConToRtype "Type" = Type tyConToRtype "Pat" = Pattern tyConToRtype _ = Expr@@ -117,64 +133,111 @@ findType :: (Data a) => a -> RType findType = tyConToRtype . dataTypeName . dataTypeOf --- Just if at least one paren was removed--- Nothing if zero parens were removed-remParens :: Brackets a => a -> Maybe a-remParens = fmap go . remParen+-- 'Just _' if at least one set of parens were removed. 'Nothing' if+-- zero parens were removed.+remParens' :: Brackets' a => a -> Maybe a+remParens' = fmap go . remParen' where- go e = maybe e go (remParen e)+ go e = maybe e go (remParen' e) -bracket :: forall a . (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => (a S -> Bool) -> Bool -> a S -> [Idea]-bracket isPartialAtom root = f Nothing- where- msg = "Redundant bracket"+isPartialAtom :: LHsExpr GhcPs -> Bool+-- Might be '$x', which was really '$ x', but TH enabled misparsed it.+isPartialAtom (LL _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True+isPartialAtom (LL _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True+isPartialAtom x = isRecConstr' x || isRecUpdate' x - -- f (Maybe (index, parent, gen)) child- f :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]- f Just{} o@(remParens -> Just x) | isAtom x, not $ isPartialAtom x = bracketError msg o x : g x- f Nothing o@(remParens -> Just x) | root || isAtom x, not $ isPartialAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x- f (Just (i,o,gen)) v@(remParens -> Just x) | not $ needBracket i o x, not $ isPartialAtom x =- suggest msg o (gen x) [r] : g x- where- typ = findType v- r = Replace typ (toSS v) [("x", toSS x)] "x"- f _ x = g x+bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea]+bracket pretty isPartialAtom root = f Nothing+ where+ msg = "Redundant bracket"+ -- 'f' is a (generic) function over types in 'Brackets'+ -- (expressions, patterns and types). Arguments are, 'f (Maybe+ -- (index, parent, gen)) child'.+ f :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => Maybe (Int, a , a -> a) -> a -> [Idea]+ -- No context. Removing parentheses from 'x' succeeds?+ f Nothing o@(remParens' -> Just x)+ -- If at the root, or 'x' is an atom, 'x' parens are redundant.+ | root || isAtom' x+ , not $ isPartialAtom x =+ (if isAtom' x then bracketError else bracketWarning) msg o x : g x+ -- In some context, removing parentheses from 'x' succeeds and 'x'+ -- is atomic?+ f Just{} o@(remParens' -> Just x)+ | isAtom' x+ , not $ isPartialAtom x =+ bracketError msg o x : g x+ -- In some context, removing parentheses from 'x' succeds. Does+ -- 'x' actually need bracketing in this context?+ f (Just (i, o, gen)) v@(remParens' -> Just x)+ | not $ needBracket' i o x, not $ isPartialAtom x =+ rawIdea' Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x+ where+ typ = findType (unLoc v)+ r = Replace typ (toSS' v) [("x", toSS' x)] "x"+ -- Regardless of the context, there are no parentheses to remove+ -- from 'x'.+ f _ x = g x - g :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]- g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o]+ g :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => a -> [Idea]+ -- Enumerate over all the immediate children of 'o' looking for+ -- redundant parentheses in each.+ g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zip [0..] $ holes o] +bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea bracketWarning msg o x =- suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ suggest' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"]++bracketError :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b ) => String -> a -> b -> Idea bracketError msg o x =- warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+ warn' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"] +fieldDecl :: LConDeclField GhcPs -> [Idea]+fieldDecl o@(LL loc f@ConDeclField{cd_fld_type=v@(LL l (HsParTy _ c))}) =+ let r = LL loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in+ [rawIdea' Suggestion "Redundant bracket" loc+ (showSDocUnsafe $ ppr_fld o) -- Note this custom printer!+ (Just (showSDocUnsafe $ ppr_fld r))+ []+ [Replace Type (toSS' v) [("x", toSS' c)] "x"]]+ where+ -- If we call 'unsafePrettyPrint' on a field decl, we won't like+ -- the output (e.g. "[foo, bar] :: T"). Here we use a custom+ -- printer to work around (snarfed from+ -- https://hackage.haskell.org/package/ghc-lib-parser-8.8.1/docs/src/HsTypes.html#pprConDeclFields).+ ppr_fld (LL _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })+ = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc+ ppr_fld (LL _ (XConDeclField x)) = ppr x+ ppr_fld _ = undefined -- '{-# COMPLETE LL #-}' -fieldDecl :: FieldDecl S -> [Idea]-fieldDecl o@(FieldDecl a b v@(TyParen _ c))- = [suggest "Redundant bracket" o (FieldDecl a b c) [Replace Type (toSS v) [("x", toSS c)] "x"]]+ ppr_names [n] = ppr n+ ppr_names ns = sep (punctuate comma (map ppr ns)) fieldDecl _ = [] --dollar :: Exp_ -> [Idea]+-- This function relies heavily on fixities having been applied to the+-- raw parse tree (c.f. 'Util.Refact.Fixings').+dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe- where- f x = [suggest "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$"- ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b, not $ isPartialAtom b- ,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]- ++- [suggest "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x- ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2- ,not $ a1 ~= "select" -- special case for esqueleto, see #224- , let y = App an a1 (Paren an a2)- , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]- ++- -- special case of (v1 . v2) <$> v3- [suggest "Redundant bracket" x y []- | InfixApp _ (Paren _ o1@(InfixApp _ v1 (isDot -> True) v2)) o2 v3 <- [x], opExp o2 ~= "<$>"- , let y = InfixApp an o1 o2 v3]-+ where+ f x = [ suggest' "Redundant $" x y [r]| o@(LL loc (OpApp _ a d b)) <- [x], isDol' d+ , let y = noLoc (HsApp noExt a b) :: LHsExpr GhcPs+ , not $ needBracket' 0 y a+ , not $ needBracket' 1 y b+ , not $ isPartialAtom b+ , let r = Replace Expr (toSS' x) [("a", toSS' a), ("b", toSS' b)] "a b"]+ +++ [ suggest' "Move brackets to avoid $" x (t y) [r]+ |(t, e@(LL _ (HsPar _ (LL _ (OpApp _ a1 op1 a2))))) <- splitInfix x+ , isDol' op1+ , isVar' a1 || isApp' a1 || isPar' a1, not $ isAtom' a2+ , varToStr' a1 /= "select" -- special case for esqueleto, see #224+ , let y = noLoc $ HsApp noExt a1 (noLoc (HsPar noExt a2))+ , let r = Replace Expr (toSS' e) [("a", toSS' a1), ("b", toSS' a2)] "a (b)" ]+ ++ -- Special case of (v1 . v2) <$> v3+ [ suggest' "Redundant bracket" x y []+ | LL _ (OpApp _ (LL _ (HsPar _ o1@(LL _ (OpApp _ v1 (isDot' -> True) v2)))) o2 v3) <- [x], varToStr' o2 == "<$>"+ , let y = noLoc (OpApp noExt o1 o2 v3) :: LHsExpr GhcPs] --- return both sides, and a way to put them together again-splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)]-splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)]+splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]+splitInfix (LL l (OpApp _ lhs op rhs)) =+ [(LL l . OpApp noExt lhs op, rhs), (\lhs -> LL l (OpApp noExt lhs op rhs), lhs)] splitInfix _ = []
src/Hint/Comment.hs view
@@ -10,7 +10,6 @@ <COMMENT> INLINE X </TEST> -}-{-# LANGUAGE PackageImports #-} module Hint.Comment(commentHint) where@@ -19,11 +18,12 @@ import Data.Char import Data.List.Extra import Refact.Types(Refactoring(ModifyComment))-import "ghc-lib-parser" SrcLoc-import "ghc-lib-parser" ApiAnnotation+import SrcLoc+import ApiAnnotation import GHC.Util -pragmas = words $+directives :: [String]+directives = words $ "LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++ "CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE" @@ -34,7 +34,7 @@ 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 ++ " #"]+ | isMultiline, name `elem` directives = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"] where isMultiline = isCommentMultiline comm s = commentText comm@@ -44,6 +44,6 @@ 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+ rawIdea' Suggestion msg 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
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} {- Find bindings within a let, and lists of statements@@ -21,32 +22,52 @@ module Hint.Duplicate(duplicateHint) where -import Hint.Type+import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning),showSrcLoc,ghcSrcLocToHSE)+import Data.Data+import Data.Generics.Uniplate.Operations import Data.Default+import Data.Maybe import Data.Tuple.Extra import Data.List hiding (find) import qualified Data.Map as Map +import SrcLoc+import HsSyn+import Outputable+import Bag+import GHC.Util duplicateHint :: CrossHint 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 (hseModule m), fromNamed d, d) | m <- map snd ms, d <- moduleDecls (hseModule m)]-+ -- Do expressions.+ dupes [ (m, d, y)+ | (m, d, x) <- ds+ , HsDo _ _ (LL _ y) :: HsExpr GhcPs <- universeBi x+ ] +++ -- Bindings in a 'let' expression or a 'where' clause.+ dupes [ (m, d, y)+ | (m, d, x) <- ds+ , HsValBinds _ (ValBinds _ b _ ) :: HsLocalBinds GhcPs <- universeBi x+ , let y = bagToList b+ ]+ where+ ds = [(modName m, fromMaybe "" (declName d), d)+ | ModuleEx _ _ m _ <- map snd ms+ , d <- map unLoc (hsmodDecls (unLoc m))] -dupes :: (Pretty (f SrcSpan), Annotated f, Ord (f ())) => [(String, String, [f S])] -> [Idea]+dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea] dupes ys =- [(rawIdeaN- (if length xs >= 5 then Warning else Suggestion)+ [(rawIdeaN'+ (if length xs >= 5 then Hint.Type.Warning else Suggestion) "Reduce duplication" p1- (unlines $ map (prettyPrint . fmap (const p1)) xs)- (Just $ "Combine with " ++ showSrcLoc (getPointLoc p2)) [])- {ideaModule = [m1,m2], ideaDecl = [d1,d2]}- | ((m1,d1,p1),(m2,d2,p2),xs) <- duplicateOrdered 3 $ map f ys]+ (unlines $ map unsafePrettyPrint xs)+ (Just $ "Combine with " +++ showSrcLoc (ghcSrcLocToHSE (srcSpanStart p2))) []+ ){ideaModule = [m1, m2], ideaDecl = [d1, d2]}+ | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys] where- f (m,d,xs) = [((m,d,srcInfoSpan $ ann x), dropAnn x) | x <- xs]-+ f (m, d, xs) =+ [((m, d, SrcSpanD (getLoc x)), wrap (stripLocs' x)) | x <- xs] --------------------------------------------------------------------- -- DUPLICATE FINDING@@ -66,13 +87,15 @@ add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp where f new = add pos vs --duplicateOrdered :: (Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])]+duplicateOrdered :: forall pos val.+ (Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])] duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs where+ f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]]) f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs where pos = Map.fromList $ zip (map fst xs) [0..] + g :: Map.Map pos Int -> Dupe pos val -> [(pos, val)] -> (Dupe pos val, [(pos, pos, [val])]) g pos d xs = (d2, res) where res = [(p,pme,take mx vs) | i >= threshold
src/Hint/Export.hs view
@@ -9,38 +9,39 @@ module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where </TEST> -}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeFamilies #-} 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+import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore',Note(..)) +import HsSyn+import Module+import SrcLoc+import OccName+import RdrName+ exportHint :: ModuHint-exportHint _ (ModuleEx _ _ (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)+exportHint _ (ModuleEx _ _ (LL 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"]}]+ let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExt name)] )} in+ [(ignore' "Use module export list" (L s o) (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]+ , modName <- moduleNameString (unLoc name)+ , names <- [ moduleNameString (unLoc n) | (LL _ (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') )}+ r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExt (noLoc (IEName (noLoc dots)))) : exports') )} in- [ignore' "Use explicit module export list" (L s o) (GHC.noLoc r) []]+ [ignore' "Use explicit module export list" (L s o) (noLoc r) []] where o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }- isMod (L _ (IEModuleContents _ _)) = True+ isMod (LL _ (IEModuleContents _ _)) = True isMod _ = False - matchesModName m (L _ (IEModuleContents _ (L _ n))) = GHC.moduleNameString n == m+ matchesModName m (LL _ (IEModuleContents _ (L _ n))) = moduleNameString n == m matchesModName _ _ = False exportHint _ _ = []
src/Hint/Extensions.hs view
@@ -253,7 +253,6 @@ used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun used NamedFieldPuns = 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
src/Hint/Import.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-} {- Reduce the number of import declarations.@@ -40,31 +39,32 @@ module Hint.Import(importHint) where -import Control.Applicative-import Data.Tuple.Extra-import Hint.Type+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest',toSS',rawIdea',rawIdeaN') import Refact.Types hiding (ModuleName) import qualified Refact.Types as R+import Data.Tuple.Extra import Data.List.Extra+import Data.Generics.Uniplate.Operations import Data.Maybe+import Control.Applicative 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 FastString+import BasicTypes+import RdrName+import Module+import HsSyn+import SrcLoc import GHC.Util importHint :: ModuHint-importHint _ ModuleEx {ghcModule=GHC.L _ HsModule{hsmodImports=ms}} =+importHint _ ModuleEx {ghcModule=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'+ , 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 ++@@ -74,8 +74,7 @@ reduceImports :: [LImportDecl GhcPs] -> [Idea] reduceImports ms =- [rawIdea Hint.Type.Warning "Use fewer imports"- (ghcSpanToHSE (getloc $ head ms)) (f ms) (Just $ f x) [] rs+ [rawIdea' Hint.Type.Warning "Use fewer imports" (getLoc $ head ms) (f ms) (Just $ f x) [] rs | Just (x, rs) <- [simplify ms]] where f = unlines . map unsafePrettyPrint @@ -97,7 +96,7 @@ combine :: LImportDecl GhcPs -> LImportDecl GhcPs -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])-combine x@(GHC.L _ x') y@(GHC.L _ y')+combine x@(LL _ x') y@(LL _ 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@@ -105,8 +104,8 @@ | 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))+ 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.@@ -121,44 +120,50 @@ -- No hints. | otherwise = Nothing where+ eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool+ eqMaybe (Just x) (Just y) = x `eqLocated` y+ eqMaybe Nothing Nothing = True+ eqMaybe _ _ = False+ qual = ideclQualified x' == ideclQualified y'- as = ideclAs x' `GHC.Util.eqMaybe` ideclAs y'+ as = ideclAs x' `eqMaybe` ideclAs y' ass = mapMaybe ideclAs [x', y'] specs = transformBi (const noSrcSpan) (ideclHiding x') == transformBi (const noSrcSpan) (ideclHiding y')+combine _ _ = Nothing -- {-# COMPLETE LL #-} stripRedundantAlias :: LImportDecl GhcPs -> [Idea]-stripRedundantAlias x@(GHC.L loc i@GHC.ImportDecl {..})+stripRedundantAlias x@(LL loc i@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)]]+ | Just (unLoc ideclName) == fmap unLoc ideclAs =+ [suggest' "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS' x)]] stripRedundantAlias _ = [] preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]-preferHierarchicalImports x@(GHC.L loc i@GHC.ImportDecl{ideclName=(GHC.L _ n),ideclPkgQual=Nothing})+preferHierarchicalImports x@(LL loc i@ImportDecl{ideclName=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)+ [rawIdeaN' Suggestion "Use hierarchical imports" 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_"]])]) []]+ , 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]+ x (noLoc (desugarQual i){ideclName=noLoc (mkModuleName newModuleName)} :: LImportDecl GhcPs) r] where -- Substitute a new module name.- f a b = (desugarQual i){ideclName=noloc (mkModuleName a), ideclHiding=b}+ 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)))))+ 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 :: ImportDecl GhcPs -> ImportDecl GhcPs desugarQual i | ideclQualified i && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)} | otherwise = i
src/Hint/List.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}- {- Find and match: @@ -31,164 +30,234 @@ foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]] foo = [fooValue | Foo{..} <- y, fooField] issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd]+{-# LANGUAGE MonadComprehensions #-}\+foo = [x | False, x <- [1 .. 10]] -- [] </TEST> -} module Hint.List(listHint) where import Control.Applicative-import Hint.Type+import Data.Generics.Uniplate.Operations import Data.List.Extra import Data.Maybe import Prelude++import Hint.Type(DeclHint',Idea,suggest',toSS')+ import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R +import HsSyn+import SrcLoc+import BasicTypes+import RdrName+import OccName+import Name+import FastString+import TysWiredIn -listHint :: DeclHint+import GHC.Util++listHint :: DeclHint' listHint _ _ = listDecl -listDecl :: Decl_ -> [Idea]+listDecl :: LHsDecl GhcPs -> [Idea] listDecl x =- concatMap (listExp False) (childrenBi x) ++- stringType x ++- concatMap listPat (childrenBi x) ++- concatMap listComp (universeBi x)+ concatMap (listExp False) (childrenBi x) +++ stringType x +++ concatMap listPat (childrenBi x) +++ concatMap listComp (universeBi x) -listComp :: Exp_ -> [Idea]-listComp o@(ListComp a e xs)- | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]- | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]- | xs /= ys = [suggest "Move guards forward" o o3 (suggestExpr o o3)]- where+-- Refer to https://github.com/ndmitchell/hlint/issues/775 for the+-- structure of 'listComp'.++listComp :: LHsExpr GhcPs -> [Idea]+listComp o@(LL _ (HsDo _ ListComp (L _ stmts))) =+ listCompCheckGuards o ListComp stmts+listComp o@(LL _ (HsDo _ MonadComp (L _ stmts))) =+ listCompCheckGuards o MonadComp stmts++listComp o@(view' -> App2' mp f (LL _ (HsDo _ ListComp (L _ stmts)))) =+ listCompCheckMap o mp f ListComp stmts+listComp o@(view' -> App2' mp f (LL _ (HsDo _ MonadComp (L _ stmts)))) =+ listCompCheckMap o mp f MonadComp stmts+listComp _ = []++listCompCheckGuards :: LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckGuards o ctx stmts =+ let revs = reverse stmts+ e@(LL _ LastStmt{}) = head revs -- In a ListComp, this is always last.+ xs = reverse (tail revs) in+ list_comp_aux e xs+ where+ list_comp_aux e xs+ | "False" `elem` cons = [suggest' "Short-circuited list comprehension" o o' (suggestExpr o o')]+ | "True" `elem` cons = [suggest' "Redundant True guards" o o2 (suggestExpr o o2)]+ | not (eqNoLocLists' xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)]+ | otherwise = []+ where ys = moveGuardsForward xs- o' = List an []- o2 = ListComp a e $ filter ((/= Just "True") . qualCon) xs- o3 = ListComp a e ys+ o' = noLoc $ ExplicitList noExt Nothing []+ o2 = noLoc $ HsDo noExt ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e]))+ o3 = noLoc $ HsDo noExt ctx (noLoc $ ys ++ [e]) cons = mapMaybe qualCon xs- qualCon (QualStmt _ (Qualifier _ (Con _ x))) = Just $ fromNamed x+ qualCon :: ExprLStmt GhcPs -> Maybe String+ qualCon (L _ (BodyStmt _ (LL _ (HsVar _ (L _ x))) _ _)) = Just (occNameString . rdrNameOcc $ x) qualCon _ = Nothing-listComp o@(view -> App2 mp f (ListComp a e xs)) | mp ~= "map" =- [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]- where o2 = ListComp a (App an (paren f) (paren e)) xs-listComp _ = [] -suggestExpr :: Exp_ -> Exp_ -> [Refactoring R.SrcSpan]-suggestExpr o o2 = [Replace Expr (toSS o) [] (prettyPrint o2)]---- Move all the list comp guards as far forward as they can go-moveGuardsForward :: [QualStmt S] -> [QualStmt S]-moveGuardsForward = reverse . f [] . reverse+listCompCheckMap ::+ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckMap o mp f ctx stmts | varToStr' mp == "map" =+ [suggest' "Move map inside list comprehension" o o2 (suggestExpr o o2)] where- f guards (x@(QualStmt _ (Generator _ p _)):xs) = reverse stop ++ x : f move xs- where (move, stop) = span (if any isPFieldWildcard (universeS x) then const False else \x -> pvars p `disjoint` vars' x) guards- f guards (x@(QualStmt _ Qualifier{}):xs) = f (x:guards) xs- f guards (x@(QualStmt _ LetStmt{}):xs) = f (x:guards) xs- f guards xs = reverse guards ++ xs+ revs = reverse stmts+ LL _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.+ last = noLoc $ LastStmt noExt (noLoc $ HsApp noExt (paren' f) (paren' body)) b s+ o2 =noLoc $ HsDo noExt ctx (noLoc $ reverse (tail revs) ++ [last])+listCompCheckMap _ _ _ _ _ = [] - -- the type QualStmt doesn't have a Var instance, so fake something that works- vars' x = [prettyPrint a | Var _ a <- universeS x]+suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]+suggestExpr o o2 = [Replace Expr (toSS' o) [] (unsafePrettyPrint o2)] +moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]+moveGuardsForward = reverse . f [] . reverse+ where+ f guards (x@(L _ (BindStmt _ p _ _ _)) : xs) = reverse stop ++ x : f move xs+ where (move, stop) =+ span (if any hasPFieldsDotDot' (universeBi x)+ || any isPFieldWildcard' (universeBi x)+ then const False+ else \x -> pvars' p `disjoint` vars_ x) guards+ f guards (x@(L _ BodyStmt{}):xs) = f (x:guards) xs+ f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs+ f guards xs = reverse guards ++ xs --- boolean = are you in a ++ chain-listExp :: Bool -> Exp_ -> [Idea]-listExp b (fromParen -> x) =- if null res then concatMap (listExp $ isAppend x) $ children x else [head res]- where- res = [suggest name x x2 [r] | (name,f) <- checks- , Just (x2, subts, temp) <- [f b x]- , let r = Replace Expr (toSS x) subts temp ]+ -- Fake something that works+ vars_ x = [unsafePrettyPrint a | HsVar _ (LL _ a) <- universeBi x :: [HsExpr GhcPs]] -listPat :: Pat_ -> [Idea]+listExp :: Bool -> LHsExpr GhcPs -> [Idea]+listExp b (fromParen' -> x) =+ if null res then concatMap (listExp $ isAppend x) $ children x else [head res]+ where+ res = [suggest' name x x2 [r]+ | (name, f) <- checks+ , Just (x2, subts, temp) <- [f b x]+ , let r = Replace Expr (toSS' x) subts temp ]++listPat :: Pat GhcPs -> [Idea] listPat x = if null res then concatMap listPat $ children x else [head res]- where res = [suggest name x x2 [r]- | (name,f) <- pchecks+ where res = [suggest' name x x2 [r]+ | (name, f) <- pchecks , Just (x2, subts, temp) <- [f x]- , let r = Replace Pattern (toSS x) subts temp ]--isAppend (view -> App2 op _ _) = op ~= "++"+ , let r = Replace Pattern (toSS' x) subts temp ]+isAppend :: View' a App2' => a -> Bool+isAppend (view' -> App2' op _ _) = varToStr' op == "++" isAppend _ = False -+checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))] checks = let (*) = (,) in drop 1 -- see #174- ["Use string literal" * useString- ,"Use list literal" * useList- ,"Use :" * useCons- ]+ [ "Use string literal" * useString+ , "Use list literal" * useList+ , "Use :" * useCons+ ] +pchecks :: [(String, Pat GhcPs -> Maybe (Pat GhcPs, [(String, R.SrcSpan)], String))] pchecks = let (*) = (,) in drop 1 -- see #174- ["Use string literal pattern" * usePString- ,"Use list literal pattern" * usePList+ [ "Use string literal pattern" * usePString+ , "Use list literal pattern" * usePList ] --usePString (PList _ xs) | xs /= [], Just s <- mapM fromPChar xs =- let literal = PLit an (Signless an) $ String an s (show s)- in Just (literal, [], prettyPrint literal)+usePString :: Pat GhcPs -> Maybe (Pat GhcPs, [a], String)+usePString (LL _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar' xs =+ let literal = noLoc $ LitPat noExt (HsString NoSourceText (fsLit (show s)))+ in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing +usePList :: Pat GhcPs -> Maybe (Pat GhcPs, [(String, R.SrcSpan)], String) usePList =- fmap ( (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s))))- . unzip- )- . f True ['a'..'z']- where- f first _ x | x ~= "[]" = if first then Nothing else Just []- f first (ident: cs) (view -> PApp_ ":" [a,b]) =- ((a, g ident a) :) <$> f False cs b- f first _ _ = Nothing+ fmap ( (\(e, s) ->+ (noLoc (ListPat noExt e)+ , map (fmap toSS') s+ , unsafePrettyPrint (noLoc $ ListPat noExt (map snd s) :: Pat GhcPs))+ )+ . unzip+ )+ . f True ['a'..'z']+ where+ f first _ x | patToStr' x == "[]" = if first then Nothing else Just []+ f first (ident:cs) (view' -> PApp_' ":" [a, b]) = ((a, g ident a) :) <$> f False cs b+ f first _ _ = Nothing - g :: Char -> Pat_ -> (String, Pat_)- g c p = ([c], PVar (ann p) (toNamed [c]))+ g :: Char -> Pat GhcPs -> (String, Pat GhcPs)+ g c p = ([c], VarPat noExt (noLoc $ mkVarUnqual (fsLit [c]))) -useString b (List _ xs) | xs /= [], Just s <- mapM fromChar xs =- let literal = Lit an $ String an s (show s)- in Just (literal , [], prettyPrint literal)-useString b _ = Nothing+useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)+useString b (LL _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar' xs =+ let literal = noLoc (HsLit noExt (HsString NoSourceText (fsLit (show s))))+ in Just (literal, [], unsafePrettyPrint literal)+useString _ _ = Nothing +useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useList b =- fmap ( (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s))))- . unzip- )- . f True ['a'..'z']- where- f first _ x | x ~= "[]" = if first then Nothing else Just []- f first (ident:cs) (view -> App2 c a b) | c ~= ":" =+ fmap ( (\(e, s) ->+ (noLoc (ExplicitList noExt Nothing e)+ , map (fmap toSS') s+ , unsafePrettyPrint (noLoc $ ExplicitList noExt Nothing (map snd s) :: LHsExpr GhcPs))+ )+ . unzip+ )+ . f True ['a'..'z']+ where+ f first _ x | varToStr' x == "[]" = if first then Nothing else Just []+ f first (ident:cs) (view' -> App2' c a b) | varToStr' c == ":" = ((a, g ident a) :) <$> f False cs b- f first _ _ = Nothing-- g :: Char -> Exp_ -> (String, Exp_)- g c p = ([c], toNamed [c])+ f first _ _ = Nothing -useCons False (view -> App2 op x y) | op ~= "++"- , Just (x2, build) <- f x- , not $ isAppend y =- Just (gen (build x2) y- , [("x", toSS x2), ("xs", toSS y)]- , prettyPrint $ gen (build $ toNamed "x") (toNamed "xs"))- where- f (List _ [x]) = Just (x, \v -> if isApp x then v else paren v)- f _ = Nothing+ g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)+ g c p = ([c], strToVar' [c]) +useCons :: View' a App2' => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)+useCons False (view' -> App2' op x y) | varToStr' op == "++"+ , Just (x2, build) <- f x+ , not $ isAppend y =+ Just (gen (build x2) y+ , [("x", toSS' x2), ("xs", toSS' y)]+ , unsafePrettyPrint $ gen (build $ strToVar' "x") (strToVar' "xs")+ )+ where+ f :: LHsExpr GhcPs ->+ Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)+ f (LL _ (ExplicitList _ _ [x]))=+ Just (x, \v -> if isApp' x then v else paren' v)+ f _ = Nothing - gen x = InfixApp an x (QConOp an $ list_cons_name an)+ gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+ gen x = noLoc . OpApp noExt x (noLoc (HsVar noExt (noLoc consDataCon_RDR))) useCons _ _ = Nothing ---typeListChar = TyList an (TyCon an (toNamed "Char"))-typeString = TyCon an (toNamed "String")+typeListChar :: LHsType GhcPs+typeListChar =+ noLoc $ HsListTy noExt+ (noLoc (HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "Char"))))) +typeString :: LHsType GhcPs+typeString =+ noLoc $ HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "String"))) -stringType :: Decl_ -> [Idea]-stringType x = case x of- InstDecl _ _ _ x -> f x- _ -> f x- where- f x = concatMap g $ childrenBi x+stringType :: LHsDecl GhcPs -> [Idea]+stringType (LL _ x) = case x of+ InstD _ ClsInstD{+ cid_inst=+ ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->+ f x ++ f y ++ f z -- Pretty much everthing but the instance type.+ _ -> f x+ where+ f x = concatMap g $ childrenBi x - g :: Type_ -> [Idea]- g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)- rs | not . null $ rs]- where f x = if x =~= typeListChar then typeString else x- rs = [Replace Type (toSS t) [] (prettyPrint typeString) | t <- universe x, t =~= typeListChar]+ g :: LHsType GhcPs -> [Idea]+ g e@(fromTyParen' -> x) = [suggest' "Use String" x (transform f x)+ rs | not . null $ rs]+ where f x = if eqNoLoc' x typeListChar then typeString else x+ rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, eqNoLoc' t typeListChar]+stringType _ = [] -- {-# COMPLETE LL #-}
src/Hint/ListRec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} {- map f [] = []@@ -29,16 +30,30 @@ module Hint.ListRec(listRecHint) where -import Hint.Type-import Hint.Util+import Hint.Type (DeclHint', Severity(Suggestion, Warning), idea', toSS')++import Data.Generics.Uniplate.Operations import Data.List.Extra import Data.Maybe import Data.Either.Extra import Control.Monad import Refact.Types hiding (RType(Match)) +import SrcLoc+import HsExtension+import HsPat+import HsTypes+import TysWiredIn+import RdrName+import HsBinds+import HsExpr+import HsDecls+import OccName+import BasicTypes -listRecHint :: DeclHint+import GHC.Util++listRecHint :: DeclHint' listRecHint _ _ = concatMap f . universe where f o = maybeToList $ do@@ -46,126 +61,163 @@ (x, addCase) <- findCase x (use,severity,x) <- matchListRec x let y = addCase x- guard $ recursiveStr `notElem` varss y- -- Maybe we can do better here maintaining source formatting?- return $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)]-+ guard $ recursiveStr `notElem` varss' y+ -- Maybe we can do better here maintaining source+ -- formatting?+ return $ idea' severity ("Use " ++ use) o y [Replace Decl (toSS' o) [] (unsafePrettyPrint y)] +recursiveStr :: String recursiveStr = "_recursive_"-recursive = toNamed recursiveStr---- recursion parameters, nil-case, (x,xs,cons-case)--- for cons-case delete any recursive calls with xs from them--- any recursive calls are marked "_recursive_"-data ListCase = ListCase [String] Exp_ (String,String,Exp_)- deriving Show+recursive = strToVar' recursiveStr +data ListCase =+ ListCase+ [String] -- recursion parameters+ (LHsExpr GhcPs) -- nil case+ (String, String, LHsExpr GhcPs) -- cons case+-- For cons-case delete any recursive calls with 'xs' in them. Any+-- recursive calls are marked "_recursive_". data BList = BNil | BCons String String- deriving (Eq,Ord,Show)---- function name, parameters, list-position, list-type, body (unmodified)-data Branch = Branch String [String] Int BList Exp_- deriving Show+ deriving (Eq, Ord, Show) +data Branch =+ Branch+ String -- function name+ [String] -- parameters+ Int -- list position+ BList (LHsExpr GhcPs) -- list type/body --------------------------------------------------------------------- -- MATCH THE RECURSION -matchListRec :: ListCase -> Maybe (String,Severity,Exp_)-matchListRec o@(ListCase vs nil (x,xs,cons))-- | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":"- , fromParen rhs =~= recursive, xs `notElem` vars lhs- = Just $ (,,) "map" Warning $ appsBracket- [toNamed "map", niceLambda [x] lhs, toNamed xs]-- | [] <- vs, App2 op lhs rhs <- view cons- , vars op `disjoint` [x,xs]- , fromParen rhs == recursive, xs `notElem` vars lhs- = Just $ (,,) "foldr" Suggestion $ appsBracket- [toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs]-- | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive- , xs `notElem` vars lhs- = Just $ (,,) "foldl" Suggestion $ appsBracket- [toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs]-- | [v] <- vs, App _ ret res <- nil, isReturn ret, res ~= "()" || view res == Var_ v- , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons- , b1 == b2, r == recursive, xs `notElem` vars e- , name <- "foldM" ++ ['_' | res ~= "()"]- = Just $ (,,) name Suggestion $ appsBracket- [toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs]-+matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs)+matchListRec o@(ListCase vs nil (x, xs, cons))+ -- Suggest 'map'?+ | [] <- vs, varToStr' nil == "[]", (LL _ (OpApp _ lhs c rhs)) <- cons, varToStr' c == ":"+ , eqNoLoc' (fromParen' rhs) recursive, xs `notElem` vars' lhs+ = Just $ (,,) "map" Hint.Type.Warning $+ appsBracket' [ strToVar' "map", niceLambda' [x] lhs, strToVar' xs]+ -- Suggest 'foldr'?+ | [] <- vs, App2' op lhs rhs <- view' cons, vars' op `disjoint` [x, xs]+ , eqNoLoc' (fromParen' rhs) recursive+ = Just $ (,,) "foldr" Suggestion $+ appsBracket' [ strToVar' "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar' xs]+ -- Suggest 'foldl'?+ | [v] <- vs, view' nil == Var_' v, (LL _ (HsApp _ r lhs)) <- cons+ , eqNoLoc' (fromParen' r) recursive+ , xs `notElem` vars' lhs+ = Just $ (,,) "foldl" Suggestion $+ appsBracket' [ strToVar' "foldl", niceLambda' [v,x] lhs, strToVar' v, strToVar' xs]+ -- Suggest 'foldM'?+ | [v] <- vs, (LL _ (HsApp _ ret res)) <- nil, isReturn' ret, varToStr' res == "()" || view' res == Var_' v+ , [LL _ (BindStmt _ (view' -> PVar_' b1) e _ _), LL _ (BodyStmt _ (fromParen' -> (LL _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons+ , b1 == b2, eqNoLoc' r recursive, xs `notElem` vars' e+ , name <- "foldM" ++ ['_' | varToStr' res == "()"]+ = Just $ (,,) name Suggestion $+ appsBracket' [strToVar' name, niceLambda' [v,x] e, strToVar' v, strToVar' xs]+ -- Nope, I got nothing ¯\_(ツ)_/¯. | otherwise = Nothing +-- Very limited attempt to convert >>= to do, only useful for+-- 'foldM' / 'foldM_'.+asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]+asDo (view' ->+ App2' bind lhs+ (LL _ (HsLam _ MG {+ mg_alts=LL _ [+ LL _ Match { m_ctxt=LambdaExpr+ , m_pats=[LL _ v@VarPat{}]+ , m_grhss=GRHSs _+ [LL _ (GRHS _ [] rhs)]+ (LL _ (EmptyLocalBinds _))}]}))+ ) =+ [ noLoc $ BindStmt noExt v lhs noSyntaxExpr' noSyntaxExpr'+ , noLoc $ BodyStmt noExt rhs noSyntaxExpr' noSyntaxExpr' ]+asDo (LL _ (HsDo _ DoExpr (LL _ stmts))) = stmts+asDo x = [noLoc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr'] --- Very limited attempt to convert >>= to do, only useful for foldM/foldM_-asDo :: Exp_ -> [Stmt S]-asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs]-asDo (Do _ x) = x-asDo x = [Qualifier an x] --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS -findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_)++findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs) findCase x = do- FunBind _ [x1,x2] <- return x- Branch name1 ps1 p1 c1 b1 <- findBranch x1- Branch name2 ps2 p2 c2 b2 <- findBranch x2- guard (name1 == name2 && ps1 == ps2 && p1 == p2)- [(BNil, b1), (BCons x xs, b2)] <- return $ sortOn fst [(c1,b1), (c2,b2)]- b2 <- transformAppsM (delCons name1 p1 xs) b2- (ps,b2) <- return $ eliminateArgs ps1 b2+ -- Match a function binding with two alternatives.+ (LL _ (ValD _ FunBind {fun_matches=+ MG{mg_alts=+ (LL _+ [ x1@(LL _ Match{..}) -- Match fields.+ , x2]), ..} -- Match group fields.+ , ..} -- Fun. bind fields.+ )) <- return x - let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b- return (ListCase ps b1 (x,xs,b2)- ,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing])+ Branch name1 ps1 p1 c1 b1 <- findBranch x1+ Branch name2 ps2 p2 c2 b2 <- findBranch x2+ guard (name1 == name2 && ps1 == ps2 && p1 == p2)+ [(BNil, b1), (BCons x xs, b2)] <- return $ sortOn fst [(c1, b1), (c2, b2)]+ b2 <- transformAppsM' (delCons name1 p1 xs) b2+ (ps, b2) <- return $ eliminateArgs ps1 b2 + let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat' (a ++ xs : b) -- Function arguments.+ emptyLocalBinds = noLoc $ EmptyLocalBinds noExt -- Empty where clause.+ gRHS e = noLoc $ GRHS noExt [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+ gRHSSs e = GRHSs noExt [gRHS e] emptyLocalBinds -- Guarded rhs set.+ match e = Match{m_ext=noExt,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.+ matchGroup e = MG{mg_alts=noLoc [noLoc $ match e], mg_origin=Generated, ..} -- Match group.+ funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind. -delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_-delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do- (pre, (view -> Var_ v):post) <- return $ splitAt pos xs+ return (ListCase ps b1 (x, xs, b2), noLoc . ValD noExt . funBind)++delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)+delCons func pos var (fromApps' -> (view' -> Var_' x) : xs) | func == x = do+ (pre, (view' -> Var_' v) : post) <- return $ splitAt pos xs guard $ v == var- return $ apps $ recursive : pre ++ post+ return $ apps' $ recursive : pre ++ post delCons _ _ _ x = return x --eliminateArgs :: [String] -> Exp_ -> ([String], Exp_)+eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons)- where- args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive]- elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False- remove = concat . zipWith (\b x -> [x | not b]) elim+ where+ args = [zs | z : zs <- map fromApps' $ universeApps' cons, eqNoLoc' z recursive]+ elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False+ remove = concat . zipWith (\b x -> [x | not b]) elim - f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs- f x = x+ f (fromApps' -> x : xs) | eqNoLoc' x recursive = apps' $ x : remove xs+ f x = x --------------------------------------------------------------------- -- FIND A BRANCH -findBranch :: Match S -> Maybe Branch-findBranch x = do- Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x- (a,b,c) <- findPat ps- return $ Branch (fromNamed name) a b c $ simplifyExp bod +findBranch :: LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch+findBranch (L _ x) = do+ Match { m_ctxt = FunRhs {mc_fun=(L _ name)}+ , m_pats = ps+ , m_grhss =+ GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]+ , grhssLocalBinds=L _ (EmptyLocalBinds _)+ }+ } <- return x+ (a, b, c) <- findPat ps+ return $ Branch (occNameString $rdrNameOcc name) a b c $ simplifyExp' body -findPat :: [Pat_] -> Maybe ([String], Int, BList)+findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList) findPat ps = do- ps <- mapM readPat ps- [i] <- return $ findIndices isRight ps- let (left,[right]) = partitionEithers ps- return (left, i, right)+ ps <- mapM readPat ps+ [i] <- return $ findIndices isRight ps+ let (left, [right]) = partitionEithers ps + return (left, i, right) -readPat :: Pat_ -> Maybe (Either String BList)-readPat (view -> PVar_ x) = Just $ Left x-readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs-readPat (PList _ []) = Just $ Right BNil+readPat :: Pat GhcPs -> Maybe (Either String BList)+readPat (view' -> PVar_' x) = Just $ Left x+readPat (LL _ (ParPat _ (LL _ (ConPatIn (L _ n) (InfixCon (view' -> PVar_' x) (view' -> PVar_' xs))))))+ | n == consDataCon_RDR = Just $ Right $ BCons x xs+readPat (LL _ (ConPatIn (L _ n) (PrefixCon [])))+ | n == nameRdrName nilDataConName = Just $ Right BNil readPat _ = Nothing
src/Hint/Match.hs view
@@ -54,6 +54,7 @@ import qualified Refact.Types as R +fmapAn :: Exp b -> Exp SrcSpanInfo fmapAn = fmap (const an)
src/Hint/Monad.hs view
@@ -64,7 +64,9 @@ import Prelude +badFuncs :: [String] badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"]+unitFuncs :: [String] unitFuncs = ["when","unless","void"] @@ -91,6 +93,7 @@ -- Sometimes people write a * do a + b, to avoid brackets+doOperator :: (Eq a, Num a) => Maybe (a, Exp S) -> Exp l -> Bool doOperator (Just (1, InfixApp _ _ op _)) InfixApp{} | not $ isDol op = True doOperator _ _ = False
src/Hint/Naming.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {- Suggest the use of camelCase @@ -42,7 +41,8 @@ module Hint.Naming(namingHint) where -import Hint.Type (Idea, DeclHint', suggest', transformBi, isSym, toSrcSpan', ghcModule)+import Hint.Type (Idea,DeclHint',suggest',isSym,toSrcSpan',ghcModule)+import Data.Generics.Uniplate.Operations import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data import Data.Char@@ -50,14 +50,15 @@ import Refact.Types hiding (RType(Match)) import qualified Data.Set as Set +import BasicTypes+import FastString+import HsDecls+import HsExtension+import HsSyn+import OccName+import SrcLoc+ 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)@@ -73,7 +74,7 @@ where suggestedNames = [ (originalName, suggestedName)- | not $ isForD $ unloc originalDecl+ | not $ isForD' originalDecl , originalName <- nubOrd $ getNames originalDecl , Just suggestedName <- [suggestName originalName] , not $ suggestedName `Set.member` seen@@ -81,27 +82,28 @@ 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 (LL locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) _) _ _))) =+ LL locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = LL locMatches $ map shortenMatch matches}})+shorten (LL locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =+ LL locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x 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 (LL locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =+ LL 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))+shortenLGRHS (LL locGRHS (GRHS ttg0 guards (LL locExpr _))) =+ LL locGRHS (GRHS ttg0 guards (cL locExpr dots)) where dots :: HsExpr GhcPs dots = HsLit NoExt (HsString (SourceText "...") (mkFastString "...")) shortenLGRHS x = x getNames :: LHsDecl GhcPs -> [String]-getNames (L _ decl) = declName decl : getConstructorNames decl+getNames (LL _ decl) = maybeToList (declName decl) ++ getConstructorNames decl+getNames _ = [] -- {-# COMPLETE LL #-} getConstructorNames :: HsDecl GhcPs -> [String] getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) =
src/Hint/NewType.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PackageImports #-} {- Suggest newtype instead of data for type declarations that have only one field. Don't suggest newtype for existentially@@ -34,10 +33,10 @@ import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN') import Data.List (isSuffixOf)-import "ghc-lib-parser" HsDecls-import "ghc-lib-parser" HsSyn-import "ghc-lib-parser" Outputable-import "ghc-lib-parser" SrcLoc+import HsDecls+import HsSyn+import Outputable+import SrcLoc newtypeHint :: DeclHint' newtypeHint _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x@@ -50,12 +49,12 @@ newtypeHintDecl _ = [] newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]-newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =+newTypeDerivingStrategiesHintDecl decl@(LL _ (TyClD _ (DataDecl _ _ _ _ dataDef))) = [ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = [] hasAllStrategies :: HsDataDefn GhcPs -> Bool-hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs+hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (LL _ xs)) = all hasStrategyClause xs hasAllStrategies _ = False isData :: HsDataDefn GhcPs -> Bool@@ -64,7 +63,7 @@ isData _ = False hasStrategyClause :: LHsDerivingClause GhcPs -> Bool-hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True+hasStrategyClause (LL _ (HsDerivingClause _ (Just _) _)) = True hasStrategyClause _ = False data WarnNewtype = WarnNewtype@@ -80,12 +79,12 @@ -- * 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] _))))+singleSimpleField (LL loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [LL _ constructor] _)))) | Just inType <- simpleCons constructor = Just WarnNewtype- { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef+ { newDecl = LL loc $ TyClD ext decl {tcdDataDefn = dataDef { dd_ND = NewType- , dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef+ , dd_cons = map (\(LL consloc x) -> LL consloc $ dropConsBang x) $ dd_cons dataDef }} , insideType = inType }@@ -94,12 +93,12 @@ -- | 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]) _)+simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [LL _ inType]) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType = Just inType-simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)+simpleCons (ConDeclH98 _ _ _ [] context (RecCon (LL _ [LL _ (ConDeclField _ [_] (LL _ inType) _)])) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType@@ -116,18 +115,18 @@ emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool emptyOrNoContext Nothing = True-emptyOrNoContext (Just (L _ [])) = True+emptyOrNoContext (Just (LL _ [])) = 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}+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (LL recloc conDeclFields)) _) =+ decl {con_args = RecCon $ cL recloc $ removeUnpacksRecords conDeclFields} where removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]- removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)+ removeUnpacksRecords = map (\(LL conDeclFieldLoc x) -> LL conDeclFieldLoc $ removeConDeclFieldUnpacks x) removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =
src/Hint/Pragma.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+ {- Suggest better pragmas OPTIONS_GHC -cpp => LANGUAGE CPP@@ -7,6 +8,7 @@ OPTIONS_GHC -XFoo => LANGUAGE Foo LANGUAGE A, A => LANGUAGE A -- do not do LANGUAGE A, LANGUAGE B to combine+ <TEST> {-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-}@@ -28,88 +30,114 @@ module Hint.Pragma(pragmaHint) where -import Hint.Type+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea',prettyExtension,glasgowExts) import Data.List.Extra import Data.Maybe import Refact.Types import qualified Refact.Types as R +import ApiAnnotation+import SrcLoc +import GHC.Util+ pragmaHint :: ModuHint-pragmaHint _ x = languageDupes lang ++ optToPragma (hseModule x) lang- where- lang = [x | x@LanguagePragma{} <- modulePragmas (hseModule x)]+pragmaHint _ modu =+ let ps = pragmas (ghcAnnotations modu)+ opts = flags ps+ lang = langExts ps in+ languageDupes lang ++ optToPragma opts lang -optToPragma :: Module_ -> [ModulePragma S] -> [Idea]-optToPragma x lang =- [pragmaIdea (OptionsToComment old ys rs) | old /= []]+optToPragma :: [(Located AnnotationComment, [String])]+ -> [(Located AnnotationComment, [String])]+ -> [Idea]+optToPragma flags langExts =+ [pragmaIdea (OptionsToComment (map fst old) ys rs) | old /= []] where- (old,new,ns, rs) =- unzip4 [(old,new,ns, r)- | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old ls]- , let r = mkRefact old new ns]-- ls = concat [map fromNamed n | LanguagePragma _ n <- lang]- ns2 = nubOrd (concat ns) \\ ls+ (old, new, ns, rs) =+ unzip4 [(old, new, ns, r)+ | old <- flags, Just (new, ns) <- [optToLanguage old ls]+ , let r = mkRefact old new ns] - ys = [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new- mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan- mkRefact old (maybe "" prettyPrint -> new) ns =- let ns' = map (\n -> prettyPrint $ LanguagePragma an [toNamed n]) ns- in- ModifyComment (toSS old) (intercalate "\n" (filter (not . null) (new: ns')))+ ls = concatMap snd langExts+ ns2 = nubOrd (concat ns) \\ ls -data PragmaIdea = SingleComment (ModulePragma S) (ModulePragma S)- | MultiComment (ModulePragma S) (ModulePragma S) (ModulePragma S)- | OptionsToComment [ModulePragma S] [ModulePragma S] [Refactoring R.SrcSpan]+ ys = [mkLangExts noSrcSpan ns2 | ns2 /= []] ++ catMaybes new+ mkRefact :: (Located AnnotationComment, [String])+ -> Maybe (Located AnnotationComment)+ -> [String]+ -> Refactoring R.SrcSpan+ mkRefact old (maybe "" comment -> new) ns =+ let ns' = map (\n -> comment (mkLangExts noSrcSpan [n])) ns+ in ModifyComment (toSS' (fst old)) (intercalate "\n" (filter (not . null) (new : ns'))) +data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)+ | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)+ | OptionsToComment [Located AnnotationComment] [Located AnnotationComment] [Refactoring R.SrcSpan] pragmaIdea :: PragmaIdea -> Idea pragmaIdea pidea = case pidea of SingleComment old new ->- mkFewer (srcInfoSpan . ann $ old)- (prettyPrint old) (Just $ prettyPrint new) []- [ModifyComment (toSS old) (prettyPrint new)]+ mkFewer (getLoc old) (comment old) (Just $ comment new) []+ [ModifyComment (toSS' old) (comment new)] MultiComment repl delete new ->- mkFewer (srcInfoSpan . ann $ repl)- (f [repl, delete]) (Just $ prettyPrint new) []- [ ModifyComment (toSS repl) (prettyPrint new)- , ModifyComment (toSS delete) ""]+ mkFewer (getLoc repl)+ (f [repl, delete]) (Just $ comment new) []+ [ ModifyComment (toSS' repl) (comment new)+ , ModifyComment (toSS' delete) ""] OptionsToComment old new r ->- mkLanguage (srcInfoSpan . ann . head $ old)+ mkLanguage (getLoc . head $ old) (f old) (Just $ f new) [] r where- f = unlines . map prettyPrint- mkFewer = rawIdea Warning "Use fewer LANGUAGE pragmas"- mkLanguage = rawIdea Warning "Use LANGUAGE pragmas"-+ f = unlines . map comment+ mkFewer = rawIdea' Hint.Type.Warning "Use fewer LANGUAGE pragmas"+ mkLanguage = rawIdea' Hint.Type.Warning "Use LANGUAGE pragmas" -languageDupes :: [ModulePragma S] -> [Idea]-languageDupes (a@(LanguagePragma _ x):xs) =- (if nub_ x `neqList` x- then [pragmaIdea (SingleComment a (LanguagePragma (ann a) $ nub_ x))]- else [pragmaIdea (MultiComment a b (LanguagePragma (ann a) (nub_ $ x ++ y))) | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++- languageDupes xs+languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]+languageDupes ( (a@(LL l _), les) : cs ) =+ (if nubOrd les /= les+ then [pragmaIdea (SingleComment a (mkLangExts l $ nubOrd les))]+ else [pragmaIdea (MultiComment a b (mkLangExts l (nubOrd $ les ++ les'))) | ( b@(LL _ _), les' ) <- cs, not $ null $ intersect les les']+ ) ++ languageDupes cs languageDupes _ = [] ---- Given a pragma, can you extract some language features out+-- Given a pragma, can you extract some language features out? strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] strToLanguage "-fglasgow-exts" = Just $ map prettyExtension glasgowExts strToLanguage _ = Nothing --optToLanguage :: ModulePragma S -> [String] -> Maybe (Maybe (ModulePragma S), [String])-optToLanguage (OptionsPragma sl tool val) ls- | maybe True (== GHC) tool && any isJust vs =- Just (res, filter (not . (`elem` ls)) (concat $ catMaybes vs))- where- strs = words val- vs = map strToLanguage strs- keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs- res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep)+-- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,+-- 'langexts' a list of all language extensions in the module enabled+-- by 'LANGUAGE' pragmas.+--+-- If ALL of the flags in the pragma enable language extensions,+-- 'return Nothing'.+--+-- If some (or all) of the flags enable options that are not language+-- extensions, compute a new options pragma with only non-language+-- extension enabling flags. Return that together with a list of any+-- language extensions enabled by this pragma that are not otherwise+-- enabled by LANGUAGE pragmas in the module.+optToLanguage :: (Located AnnotationComment, [String])+ -> [String]+ -> Maybe (Maybe (Located AnnotationComment), [String])+optToLanguage (LL loc _, flags) langExts+ | any isJust vs =+ -- 'ls' is a list of language features enabled by this+ -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas+ -- in this module.+ let ls = filter (not . (`elem` langExts)) (concat $ catMaybes vs) in+ Just (res, ls)+ where+ -- Try reinterpreting each flag as a list of language features+ -- (e.g. via '-X'..., '-fglasgow-exts').+ vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]'+ -- Keep any flag that does not enable language extensions.+ keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags+ -- If there are flags to keep, 'res' is a new pragma setting just those flags.+ res = if null keep then Nothing else Just (mkFlags loc keep) optToLanguage _ _ = Nothing
src/Hint/Restrict.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} module Hint.Restrict(restrictHint) where @@ -13,24 +14,38 @@ </TEST> -} -import qualified Data.Map as Map+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn',rawIdea') import Config.Type-import Hint.Type++import Data.Generics.Uniplate.Operations+import qualified Data.Map as Map import Data.List import Data.Maybe import Data.Semigroup import Control.Applicative+import Control.Monad import Prelude +import HsSyn+import RdrName+import ApiAnnotation+import Module+import SrcLoc+import OccName+import GHC.Util -- 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 (hseModule m)) restrict ++- maybe [] (checkImports modu $ moduleImports (hseModule m)) (Map.lookup RestrictModule restrict) ++- maybe [] (checkFunctions modu $ moduleDecls (hseModule m)) (Map.lookup RestrictFunction restrict)+ let anns = ghcAnnotations m+ ps = pragmas anns+ opts = flags ps+ exts = langExts ps in+ checkPragmas modu opts exts restrict +++ maybe [] (checkImports modu $ hsmodImports (unLoc (ghcModule m))) (Map.lookup RestrictModule restrict) +++ maybe [] (checkFunctions modu $ hsmodDecls (unLoc (ghcModule m))) (Map.lookup RestrictFunction restrict) where- modu = moduleName (hseModule m)+ modu = modName (ghcModule m) restrict = restrictions settings ---------------------------------------------------------------------@@ -39,64 +54,73 @@ data RestrictItem = RestrictItem {riAs :: [String] ,riWithin :: [(String, String)]+ ,riMessage :: Maybe String } instance Semigroup RestrictItem where- RestrictItem x1 x2 <> RestrictItem y1 y2 = RestrictItem (x1<>y1) (x2<>y2)+ RestrictItem x1 x2 x3 <> RestrictItem y1 y2 y3 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) instance Monoid RestrictItem where- mempty = RestrictItem [] []+ mempty = RestrictItem [] [] Nothing mappend = (<>) restrictions :: [Setting] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) restrictions settings = Map.map f $ Map.fromListWith (++) [(restrictType x, [x]) | SettingRestrict x <- settings] where f rs = (all restrictDefault rs- ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin) | Restrict{..} <- rs, s <- restrictName])+ ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictMessage) | Restrict{..} <- rs, s <- restrictName]) -ideaMayBreak w = w{ideaNote=[Note "may break the code"]}++ideaMessage :: Maybe String -> Idea -> Idea+ideaMessage (Just message) w = w{ideaNote=[Note message]}+ideaMessage Nothing w = w{ideaNote=[noteMayBreak]}++ideaNoTo :: Idea -> Idea ideaNoTo w = w{ideaTo=Nothing} +noteMayBreak :: Note+noteMayBreak = Note "may break the code"+ within :: String -> String -> RestrictItem -> Bool within modu func RestrictItem{..} = any (\(a,b) -> (a == modu || a == "") && (b == func || b == "")) riWithin --------------------------------------------------------------------- -- CHECKS -checkPragmas :: String -> [ModulePragma S] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) -> [Idea]-checkPragmas modu xs mps = f RestrictFlag "flags" onFlags ++ f RestrictExtension "extensions" onExtensions- where- f tag name sel =- [ (if null good then ideaNoTo else id) $ ideaMayBreak $ warn ("Avoid restricted " ++ name) o (regen good) []- | Just mp <- [Map.lookup tag mps]- , o <- xs, Just (xs, regen) <- [sel o]- , let (good, bad) = partition (isGood mp) xs, not $ null bad]-- onFlags (OptionsPragma s t x) = Just (words x, OptionsPragma s t . unwords)- onFlags _ = Nothing-- onExtensions (LanguagePragma s xs) = Just (map fromNamed xs, LanguagePragma (s :: S) . map toNamed)- onExtensions _ = Nothing-- isGood (def, mp) x = maybe def (within modu "") $ Map.lookup x mp-+checkPragmas :: String+ -> [(Located AnnotationComment, [String])]+ -> [(Located AnnotationComment, [String])]+ -> Map.Map RestrictType (Bool, Map.Map String RestrictItem)+ -> [Idea]+checkPragmas modu flags exts mps =+ f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts+ where+ f tag name xs =+ [(if null good then ideaNoTo else id) $ notes $ rawIdea' Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []+ | Just (def, mp) <- [Map.lookup tag mps]+ , (L l (AnnBlockComment c), les) <- xs+ , let (good, bad) = partition (isGood def mp) les+ , let note = maybe noteMayBreak Note . (=<<) riMessage . flip Map.lookup mp+ , let notes w = w {ideaNote=note <$> bad}+ , not $ null bad]+ isGood def mp x = maybe def (within modu "") $ Map.lookup x mp -checkImports :: String -> [ImportDecl S] -> (Bool, Map.Map String RestrictItem) -> [Idea]+checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkImports modu imp (def, mp) =- [ ideaMayBreak $ if not allowImport- then ideaNoTo $ warn "Avoid restricted module" i i []- else warn "Avoid restricted qualification" i i{importAs=ModuleName an <$> listToMaybe riAs} []- | i@ImportDecl{..} <- imp- , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def]) (fromModuleName importModule) mp+ [ ideaMessage riMessage $ if not allowImport+ then ideaNoTo $ warn' "Avoid restricted module" i i []+ else warn' "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []+ | i@(LL _ ImportDecl {..}) <- imp+ , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] Nothing) (moduleNameString (unLoc ideclName)) mp , let allowImport = within modu "" ri- , let allowQual = maybe True (\x -> null riAs || fromModuleName x `elem` riAs) importAs+ , let allowQual = maybe True (\x -> null riAs || moduleNameString (unLoc x) `elem` riAs) ideclAs , not allowImport || not allowQual ] --checkFunctions :: String -> [Decl_] -> (Bool, Map.Map String RestrictItem) -> [Idea]+checkFunctions :: String -> [LHsDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkFunctions modu decls (def, mp) =- [ (ideaMayBreak $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}+ [ (ideaMessage riMessage $ ideaNoTo $ warn' "Avoid restricted function" x x []){ideaDecl = [dname]} | d <- decls- , let dname = fromNamed d- , x <- universeBi d :: [QName S]- , not $ maybe def (within modu dname) $ Map.lookup (fromNamed x) mp+ , let dname = fromMaybe "" (declName (unLoc d))+ , x <- universeBi d :: [Located RdrName]+ , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] Nothing) (occNameString (rdrNameOcc (unLoc x))) mp+ , not $ within modu dname ri ]
src/Hint/Smell.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ViewPatterns #-} module Hint.Smell ( smellModuleHint,@@ -79,22 +78,36 @@ </TEST> -} -import Hint.Type+import Hint.Type(ModuHint,ModuleEx(..),DeclHint',Idea(..),rawIdea',warn') import Config.Type++import Data.Generics.Uniplate.Operations import Data.List.Extra import qualified Data.Map as Map +import BasicTypes+import HsSyn+import RdrName+import Outputable+import Bag+import SrcLoc+import GHC.Util+ smellModuleHint :: [Setting] -> ModuHint-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- in [rawIdea Warning "Many imports" span displayImports Nothing [] [] ]- where- f = trimStart . prettyPrint- _ -> []+smellModuleHint settings scope m =+ let (L _ mod) = ghcModule m+ imports = hsmodImports mod in+ case Map.lookup SmellManyImports (smells settings) of+ Just n | length imports >= n ->+ let span = foldl1 combineSrcSpans $ getLoc <$> imports+ displayImports = unlines $ f <$> imports+ in [rawIdea' Config.Type.Warning "Many imports" span displayImports Nothing [] [] ]+ where+ f :: LImportDecl GhcPs -> String+ f = trimStart . unsafePrettyPrint+ _ -> [] -smellHint :: [Setting] -> DeclHint+smellHint :: [Setting] -> DeclHint' smellHint settings scope m d = sniff smellLongFunctions SmellLongFunctions ++ sniff smellLongTypeLists SmellLongTypeLists ++@@ -102,46 +115,69 @@ where sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings) -smellLongFunctions :: Decl_ -> Int -> [Idea]+smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea] smellLongFunctions d n = [ idea | (span, idea) <- declSpans d , spanLength span >= n ] -declSpans :: Decl_ -> [(SrcSpanInfo, Idea)]-declSpans (FunBind _ [Match _ _ _ rhs where_]) = rhsSpans rhs ++ whereSpans where_-declSpans f@(FunBind l match) = [(l, warn "Long function" f f [])] -- count where clauses-declSpans (PatBind _ _ rhs where_) = rhsSpans rhs ++ whereSpans where_-declSpans _ = []+-- I've tried to be faithful to the original here but I'm doubtful+-- about it. I think I've replicated the behavior of the original but+-- is the original correctly honoring the intent? -whereSpans :: Maybe (Binds SrcSpanInfo) -> [(SrcSpanInfo, Idea)]-whereSpans (Just (BDecls _ decls)) = concatMap declSpans decls-whereSpans _ = []+-- A function with with one alternative, one rhs and its 'where'+-- clause (perhaps we should be looping over alts and all guarded+-- right hand sides?)+declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]+declSpans+ (LL _ (ValD _+ FunBind {fun_matches=MG {+ mg_alts=(LL _ [LL _ Match {+ m_ctxt=ctx+ , m_grhss=GRHSs{grhssGRHSs=[locGrhs]+ , grhssLocalBinds=where_}}])}})) =+ -- The span of the right hand side and the spans of each binding in+ -- the where clause.+ rhsSpans ctx locGrhs ++ whereSpans where_+-- Any other kind of function.+declSpans f@(LL l (ValD _ FunBind {})) = [(l, warn' "Long function" f f [])]+declSpans _ = [] -rhsSpans :: Rhs SrcSpanInfo -> [(SrcSpanInfo, Idea)]-rhsSpans (UnGuardedRhs l RecConstr{}) = [] --- record constructors get a pass-rhsSpans r@(UnGuardedRhs l _) = [(l, warn "Long function" r r [])]-rhsSpans r@(GuardedRhss l _) = [(l, warn "Long function" r r [])]+-- The span of a guarded right hand side.+rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]+rhsSpans _ (LL _ (GRHS _ _ (LL _ RecordCon {}))) = [] -- record constructors get a pass+rhsSpans ctx (LL _ r@(GRHS _ _ (LL l _))) =+ [(l, rawIdea' Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]+rhsSpans _ _ = [] -spanLength :: SrcSpanInfo -> Int-spanLength (SrcSpanInfo span _) = srcSpanEndLine span - srcSpanStartLine span + 1+-- The spans of a 'where' clause are the spans of its bindings.+whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]+whereSpans (LL l (HsValBinds _ (ValBinds _ bs _))) =+ concatMap (declSpans . (\(LL loc bind) -> LL loc (ValD noExt bind))) (bagToList bs)+whereSpans _ = [] -smellLongTypeLists :: Decl_ -> Int -> [Idea]-smellLongTypeLists d@(TypeSig _ _ t) n = warn "Long type list" d d [] <$ filter longTypeList (universe t)+spanLength :: SrcSpan -> Int+spanLength (RealSrcSpan span) = srcSpanEndLine span - srcSpanStartLine span + 1+spanLength (UnhelpfulSpan _) = -1++smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]+smellLongTypeLists d@(LL _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (LL _ t)))))) n =+ warn' "Long type list" d d [] <$ filter longTypeList (universe t) where- longTypeList (TyPromoted _ (PromotedList _ _ x)) = length x >= n+ longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n longTypeList _ = False smellLongTypeLists _ _ = [] -smellManyArgFunctions :: Decl_ -> Int -> [Idea]-smellManyArgFunctions d@(TypeSig _ _ t) n = warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)+smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]+smellManyArgFunctions d@(LL _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (LL _ t)))))) n =+ warn' "Many arg function" d d [] <$ filter manyArgFunction (universe t) where- manyArgFunction x = countFunctionArgs x >= n+ manyArgFunction t = countFunctionArgs t >= n smellManyArgFunctions _ _ = [] -countFunctionArgs :: Type l -> Int-countFunctionArgs (TyFun _ _ b) = 1 + countFunctionArgs b-countFunctionArgs (TyParen _ t) = countFunctionArgs t+countFunctionArgs :: HsType GhcPs -> Int+countFunctionArgs (HsFunTy _ _ t) = 1 + countFunctionArgs (unLoc t)+countFunctionArgs (HsParTy _ t) = countFunctionArgs (unLoc t) countFunctionArgs _ = 0 smells :: [Setting] -> Map.Map SmellType Int
src/Hint/Type.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PackageImports #-} module Hint.Type( DeclHint, DeclHint', ModuHint, CrossHint, Hint(..),@@ -11,8 +10,8 @@ import Idea as Export import Prelude import Refact as Export-import "ghc-lib-parser" HsExtension-import "ghc-lib-parser" HsDecls+import HsExtension+import HsDecls type DeclHint = Scope -> ModuleEx -> Decl_ -> [Idea] type DeclHint' = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
src/Hint/Unsafe.hs view
@@ -18,36 +18,68 @@ module Hint.Unsafe(unsafeHint) where -import Hint.Type+import Hint.Type(DeclHint',ModuleEx(..),Severity(..),rawIdea',toSS') import Data.Char-import Refact.Types+import Refact.Types hiding(Match)+import Data.Generics.Uniplate.Operations +import HsSyn+import OccName+import RdrName+import FastString+import BasicTypes+import SrcLoc+import GHC.Util -unsafeHint :: DeclHint-unsafeHint _ m = \d ->- [ rawIdea Warning "Missing NOINLINE pragma" (srcInfoSpan $ ann d)- (prettyPrint d)- (Just $ dropWhile isSpace (prettyPrint $ gen x) ++ "\n" ++ prettyPrint d)- [] [InsertComment (toSS d) (prettyPrint $ gen x)]- | d@(PatBind _ (PVar _ x) _ _) <- [d]- , isUnsafeDecl d, x `notElem_` noinline]- where- gen x = InlineSig an False Nothing $ UnQual an x- noinline = [q | InlineSig _ False Nothing (UnQual _ q) <- moduleDecls (hseModule m)]+-- The conditions on which to fire this hint are subtle. We are+-- interested exclusively in application constants involving+-- 'unsafePerformIO'. For example,+-- @+-- f = \x -> unsafePerformIO x+-- @+-- is not such a declaration (the right hand side is a lambda, not an+-- application) whereas,+-- @+-- f = g where g = unsafePerformIO Multimap.newIO+-- @+-- is. We advise that such constants should have a @NOINLINE@ pragma.+unsafeHint :: DeclHint'+unsafeHint _ (ModuleEx _ _ (L _ m) _) = \(L loc d) ->+ [rawIdea' Hint.Type.Warning "Missing NOINLINE pragma" loc+ (unsafePrettyPrint d)+ (Just $ dropWhile isSpace (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)+ [] [InsertComment (toSS' (L loc d)) (unsafePrettyPrint $ gen x)]+ -- 'x' does not declare a new function.+ | d@(ValD _+ FunBind {fun_id=L _ (Unqual x)+ , fun_matches=MG{mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]+ -- 'x' is a synonym for an appliciation involing 'unsafePerformIO'+ , isUnsafeDecl d+ -- 'x' is not marked 'NOINLINE'.+ , x `notElem` noinline]+ where+ gen :: OccName -> LHsDecl GhcPs+ gen x = noLoc $+ SigD noExt (InlineSig noExt (noLoc (mkRdrUnqual x))+ (InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike))+ noinline :: [OccName]+ noinline = [q | LL _(SigD _ (InlineSig _ (L _ (Unqual q))+ (InlinePragma _ NoInline Nothing NeverActive FunLike))+ ) <- hsmodDecls m] -isUnsafeDecl :: Decl_ -> Bool-isUnsafeDecl (PatBind _ _ rhs bind) =- any isUnsafeApp (childrenBi rhs) || any isUnsafeDecl (childrenBi bind)+isUnsafeDecl :: HsDecl GhcPs -> Bool+isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_alts=LL _ alts}}) =+ any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False --- Am I equivalent to @unsafePerformIO x@-isUnsafeApp :: Exp_ -> Bool-isUnsafeApp (InfixApp _ x d _) | isDol d = isUnsafeFun x-isUnsafeApp (App _ x _) = isUnsafeFun x+-- Am I equivalent to @unsafePerformIO x@?+isUnsafeApp :: HsExpr GhcPs -> Bool+isUnsafeApp (OpApp _ (LL _ l) op _ ) | isDol' op = isUnsafeFun l+isUnsafeApp (HsApp _ (LL _ x) _) = isUnsafeFun x isUnsafeApp _ = False --- Am I equivalent to @unsafePerformIO . x@-isUnsafeFun :: Exp_ -> Bool-isUnsafeFun (Var _ x) | x ~= "unsafePerformIO" = True-isUnsafeFun (InfixApp _ x d _) | isDot d = isUnsafeFun x+-- Am I equivalent to @unsafePerformIO . x@?+isUnsafeFun :: HsExpr GhcPs -> Bool+isUnsafeFun (HsVar _ (LL _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True+isUnsafeFun (OpApp _ (LL _ l) op _) | isDot' op = isUnsafeFun l isUnsafeFun _ = False
src/Hint/Util.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Hint.Util(niceLambda, simplifyExp, niceLambdaR) where+module Hint.Util(niceLambdaR) where import HSE.All import Data.List.Extra@@ -8,10 +8,6 @@ import Refact import qualified Refact.Types as R (SrcSpan) -niceLambda :: [String] -> Exp_ -> Exp_-niceLambda ss e = fst (niceLambdaR ss e)-- -- | Generate a lambda, but prettier (if possible). -- Generally no lambda is good, but removing just some arguments isn't so useful. niceLambdaR :: [String] -> Exp_ -> (Exp_, R.SrcSpan -> [Refactoring R.SrcSpan])@@ -97,15 +93,3 @@ niceDotApp :: Exp_ -> Exp_ -> Exp_ niceDotApp a b | a ~= "$" = b | otherwise = dotApp a b------ | Convert expressions which have redundant junk in them away.--- Mainly so that later stages can match on fewer alternatives.-simplifyExp :: Exp_ -> Exp_-simplifyExp (InfixApp _ x dol y) | isDol dol = App an x (paren y)-simplifyExp (Let _ (BDecls _ [PatBind _ (view -> PVar_ x) (UnGuardedRhs _ y) Nothing]) z)- | x `notElem` vars y && length [() | UnQual _ a <- universeS z, prettyPrint a == x] <= 1 = transform f z- where f (view -> Var_ x') | x == x' = paren y- f x = x-simplifyExp x = x
src/Idea.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-}-{-# LANGUAGE PackageImports #-} module Idea( Idea(..),- rawIdea, idea, idea', suggest, suggest', warn, warn',ignore, ignore',- rawIdeaN, suggestN, suggestN', ignoreN, ignoreNoSuggestion',+ rawIdea, rawIdea', idea, idea', suggest, suggest', warn, warn',ignore, ignore',+ rawIdeaN, rawIdeaN', suggestN, suggestN', ignoreN, ignoreN', ignoreNoSuggestion', showIdeasJson, showANSI, Note(..), showNotes, Severity(..),@@ -18,8 +17,8 @@ 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 SrcLoc as GHC+import qualified Outputable import qualified GHC.Util as GHC -- | An idea suggest by a 'Hint'.@@ -84,16 +83,23 @@ rawIdea :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea rawIdea = Idea [] []++rawIdea' :: Severity -> String -> GHC.SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea+rawIdea' a b c = Idea [] [] a b (ghcSpanToHSE c)+ rawIdeaN :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea rawIdeaN a b c d e f = Idea [] [] a b c d e f [] +rawIdeaN' :: Severity -> String -> GHC.SrcSpan -> String -> Maybe String -> [Note] -> Idea+rawIdeaN' a b c d e f = Idea [] [] a b (ghcSpanToHSE 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' :: (GHC.HasSrcSpan a, Outputable.Outputable a, GHC.HasSrcSpan b, Outputable.Outputable b) =>+ Severity -> String -> a -> b -> [Refactoring R.SrcSpan] -> Idea idea' severity hint from to = rawIdea severity hint (ghcSpanToHSE (GHC.getLoc from)) (GHC.unsafePrettyPrint from) (Just $ GHC.unsafePrettyPrint to) [] @@ -101,16 +107,16 @@ 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' :: (GHC.HasSrcSpan a, Outputable.Outputable a, GHC.HasSrcSpan b, Outputable.Outputable b) =>+ String -> a -> b -> [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' :: (GHC.HasSrcSpan a, Outputable.Outputable a, GHC.HasSrcSpan b, Outputable.Outputable b) =>+ String -> a -> b -> [Refactoring R.SrcSpan] -> Idea warn' = idea' Warning ignoreNoSuggestion' :: (GHC.HasSrcSpan a, Outputable.Outputable a)@@ -144,3 +150,7 @@ ignoreN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) => String -> ast SrcSpanInfo -> a -> Idea ignoreN = ideaN Ignore++ignoreN' :: (GHC.HasSrcSpan a, Outputable.Outputable a) =>+ String -> a -> a -> Idea+ignoreN' = ideaN' Ignore
src/Language/Haskell/HLint4.hs view
@@ -39,11 +39,13 @@ import SrcLoc import CmdLine import Paths_hlint+import qualified GHC.Util.Refact.Fixity as GHC import Data.List.Extra import Data.Maybe import System.FilePath import Data.Functor+import qualified Data.Map as Map import Prelude @@ -140,8 +142,13 @@ 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.+-- | Create a 'ModuleEx' from GHC annotations and module tree. Note+-- that any hints that work on the @haskell-src-exts@ won't work. It+-- is assumed the incoming parse module has not been adjusted to+-- account for operator fixities. createModuleEx:: GHC.ApiAnns -> Located (GHC.HsModule GHC.GhcPs) -> ModuleEx-createModuleEx anns ast = ModuleEx empty [] ast anns- where empty = Module an Nothing [] [] []+createModuleEx anns ast =+ let fixities = [] -- Use builtin fixities.+ (_, ast') = GHC.applyFixities Map.empty fixities ast in+ ModuleEx empty [] ast' anns+ where empty = Module an Nothing [] [] []
src/Refact.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PackageImports #-} module Refact ( toRefactSrcSpan , toSS, toSS'@@ -8,7 +7,7 @@ import qualified Refact.Types as R import HSE.All -import qualified "ghc-lib-parser" SrcLoc as GHC+import qualified SrcLoc as GHC toRefactSrcSpan :: SrcSpan -> R.SrcSpan toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss)@@ -31,5 +30,5 @@ GHC.UnhelpfulSpan _ -> R.SrcSpan 0 0 0 0 -toSS' :: GHC.Located e -> R.SrcSpan+toSS' :: GHC.HasSrcSpan e => e -> R.SrcSpan toSS' = toRefactSrcSpan . ghcSpanToHSE . GHC.getLoc
src/Test/All.hs view
@@ -51,10 +51,11 @@ wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file+ let hs = [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"] when cmdTypeCheck $ wrap "Hint typechecking" $- progress >> testTypeCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+ progress >> testTypeCheck cmdDataDir cmdTempDir hs when cmdQuickCheck $ wrap "Hint QuickChecking" $- progress >> testQuickCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+ progress >> testQuickCheck cmdDataDir cmdTempDir hs when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" getIdeas
src/Test/Annotations.hs view
@@ -106,6 +106,7 @@ f _ [] = [] +parseTest :: String -> Int -> String -> [Setting] -> TestCase parseTest file i x = uncurry (TestCase (SrcLoc file i 0)) $ f x where f x | Just x <- stripPrefix "<COMMENT>" x = first ("--"++) $ f x
src/Test/Proof.hs view
@@ -59,6 +59,7 @@ where n = maximum $ map (length . fst) xs +missingFuncs :: [(String, String)] missingFuncs = let a*b = [(b,a) | b <- words b] in concat ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin" ,"Exit" * "exitSuccess"
src/Test/Translate.hs view
@@ -101,5 +101,6 @@ restrict _ v = toNamed v +isRemovesError :: Note -> Bool isRemovesError RemovesError{} = True isRemovesError _ = False
src/Util.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE ExistentialQuantification, Rank2Types #-} module Util(- defaultExtensions,+ parseExtensions,+ configExtensions, forceList, gzip, universeParentBi, exitMessage, exitMessageImpure,@@ -72,9 +73,15 @@ --------------------------------------------------------------------- -- LANGUAGE.HASKELL.EXTS.EXTENSION -defaultExtensions :: [Extension]-defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions+-- | Extensions we turn on by default when parsing. Aim to parse as many files as we can.+parseExtensions :: [Extension]+parseExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions +-- | Extensions we turn on when reading config files, don't have to deal with the whole world+-- of variations - in particular, we might require spaces in some places.+configExtensions :: [Extension]+configExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension reallyBadExtensions+ badExtensions = [Arrows -- steals proc ,TransformListComp -- steals the group keyword@@ -83,4 +90,8 @@ ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break ,DoRec, RecursiveDo -- breaks rec ,TypeApplications -- HSE fails on @ patterns+ ]++reallyBadExtensions =+ [TransformListComp -- steals the group keyword ]