hlint 2.2.11 → 3.0

raw patch · 75 files changed

+2493/−2931 lines, 75 filesdep −haskell-src-extsdep −haskell-src-exts-utildep ~extradep ~ghcdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependencies removed: haskell-src-exts, haskell-src-exts-util

Dependency ranges changed: extra, ghc, ghc-lib-parser, ghc-lib-parser-ex

API changes (from Hackage documentation)

Files

• CHANGES.txt +53/−0
• README.md +4/−1
• data/HLint_QuickCheck.hs +0/−1
• data/HLint_TypeCheck.hs +0/−1
• data/hlint.yaml +135/−12
• hlint.cabal +16/−24
• src/Apply.hs +29/−22
• src/CC.hs +7/−5
• src/CmdLine.hs +47/−60
• src/Config/Compute.hs +51/−33
• src/Config/Haskell.hs +27/−116
• src/Config/Read.hs +10/−6
• src/Config/Type.hs +9/−12
• src/Config/Yaml.hs +77/−95
• src/Extension.hs +61/−0
• src/Fixity.hs +105/−0
• src/GHC/Util.hs +79/−10
• src/GHC/Util/ApiAnnotation.hs +2/−2
• src/GHC/Util/Brackets.hs +46/−41
• src/GHC/Util/DynFlags.hs +5/−1
• src/GHC/Util/FreeVars.hs +97/−97
• src/GHC/Util/HsDecl.hs +5/−17
• src/GHC/Util/HsExpr.hs +112/−82
• src/GHC/Util/HsType.hs +0/−23
• src/GHC/Util/LanguageExtensions/Type.hs +0/−13
• src/GHC/Util/Module.hs +4/−6
• src/GHC/Util/Pat.hs +0/−58
• src/GHC/Util/Scope.hs +33/−37
• src/GHC/Util/Unify.hs +108/−61
• src/GHC/Util/View.hs +23/−17
• src/Grep.hs +16/−13
• src/HLint.hs +23/−65
• src/HSE/All.hs +66/−293
• src/HSE/Match.hs +0/−142
• src/HSE/Scope.hs +0/−48
• src/HSE/Type.hs +0/−18
• src/HSE/Util.hs +0/−420
• src/Hint/All.hs +13/−16
• src/Hint/Bracket.hs +32/−26
• src/Hint/Comment.hs +2/−2
• src/Hint/Duplicate.hs +14/−14
• src/Hint/Export.hs +10/−10
• src/Hint/Extensions.hs +165/−76
• src/Hint/Import.hs +12/−13
• src/Hint/Lambda.hs +177/−87
• src/Hint/List.hs +55/−46
• src/Hint/ListRec.hs +45/−44
• src/Hint/Match.hs +73/−68
• src/Hint/Monad.hs +83/−70
• src/Hint/Naming.hs +27/−23
• src/Hint/NewType.hs +25/−24
• src/Hint/Pattern.hs +79/−73
• src/Hint/Pragma.hs +10/−8
• src/Hint/Restrict.hs +2/−2
• src/Hint/Smell.hs +10/−10
• src/Hint/Type.hs +7/−10
• src/Hint/Unsafe.hs +11/−11
• src/Hint/Util.hs +0/−95
• src/HsColour.hs +1/−1
• src/Idea.hs +21/−45
• src/Language/Haskell/HLint.hs +136/−27
• src/Language/Haskell/HLint3.hs +0/−7
• src/Language/Haskell/HLint4.hs +0/−152
• src/Main.hs +1/−1
• src/Parallel.hs +4/−4
• src/Refact.hs +51/−18
• src/Report.hs +5/−5
• src/Test/All.hs +19/−11
• src/Test/Annotations.hs +97/−30
• src/Test/InputOutput.hs +9/−4
• src/Test/Proof.hs +16/−3
• src/Test/Translate.hs +27/−6
• src/Test/Util.hs +2/−5
• src/Timing.hs +2/−2
• src/Util.hs +0/−30

@@ -1,5 +1,58 @@ Changelog for HLint (* = breaking change) +3.0, released 2020-05-02+    Be more permissive with names'with'quotes'in+    #953, fix incorrect suggestions with free variables and \case+    #955, make --find generate fixity: not infix:+    #952, improve refactorings with qualified imports+    #945, suggest Map.fromList [] ==> Map.empty+    #949, warn about redundant fmaps with binds+    #950, reduce the span of "Redundant $" to only cover the "$"+    #944, reduce the span of "Use let" to only cover the "let" line+    #669, don't suggest replacing reverse . sort (it's quite fast)+    #939, reduce the span of "Redundant where" to only cover the "where"+    Remove support for GHC 8.4+    Remove support for _eval,+    #926, fix refactoring when the hint contains _noParen_+    #933, improve the output for Redundant do hints+*   Merge ParseMode into ParseFlags+*   Rename Language.Haskell.HLint3,HLint4 to Language.Haskell.HLint+*   Delete the old Language.Haskell.HLint+    #881, add a monomorphic group of hints+    #837, don't suggest redundant do if its being used for brackets+    #923, don't suggest eta reducing infix definitions+    #931, disable StaticPointers extension by default+    #924, remove dependency on haskell-src-exts+    #922, reduce the span of "Redundant do" to only cover the "do"+    #919, more specific names for foldMap fusion rules+    #918, warn on unused TypeOperators+    #916, warn on unused InstanceSigs+    Improve parse error context messages+*   Most parse errors are fixed+    #881, disable hints about maybe that are sometimes wrong+    #909, be more careful about redundant bracket warnings+    #905, match hints even if there is composition to the left+    #904, suggest map/fromMaybe[] becomes maybe [] map+*   Remove the hse command line argument, to parse a file with HSE+    #901, warn on unused MultiWayIf+    Don't raise a parse error if haskell-src-exts can't parse code+    #899, warn on unused PatternSynonyms+    #898, don't suggest removing NamedFieldPuns with record updates+*   Make any --hint flag disable implicit .hlint.yaml search+*   Delete the --with flag+*   Haskell hint definitions are no longer supported (use YAML)+*   Report hints with src-span information, e.g. file:1:1-10+*   Delete resolveHints (it was the identity)+*   Change to GHC types in the API+    Add --with-group=future to add return ==> pure hint+    #888, suggest foldr from (.) to ($) in some cases+    #884, add more >=> operator hints+    #875, fix the extension implication information+    Add --with-group=extra to give extra library hints+    #873, add more Applicative hints+    #872, fix refactoring in hints to use lists+    #871, warn when fmapping the result of gets or asks+    #869, improve hints for maybe/fromMaybe on Bool 2.2.11, released 2020-02-09     #868, fix some brackets in refactoring suggestions     #865, suggest biList if generalise-for-conciseness is turned on

@@ -14,7 +14,10 @@ * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. * Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types.+* Sometimes HLint will change the code in a way that causes values to default to different types, which may change the behaviour.+* HLint assumes duplicate identical expressions within in a single expression are used at the same type. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes.+* HLint can be configured with knowledge of C Pre Processor flags, but it can only see one conditional set of code at a time. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`, `foo $bar` means something different with `TemplateHaskell`. These extensions can be disabled with `-XNoMagicHash` or `-XNoTemplateHaskell` etc. * HLint doesn't run any custom preprocessors, e.g. [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) or [record-dot-preprocessor](https://hackage.haskell.org/package/record-dot-preprocessor), so code making use of them will usually fail to parse. @@ -95,7 +98,7 @@ By supplying the `--refactor` flag hlint can automatically apply most suggestions. Instead of a list of hints, hlint will instead output the refactored file on stdout. In order to do this, it is necessary to have the-`refactor` executable on you path. `refactor` is provided by the+`refactor` executable on your path. `refactor` is provided by the [`apply-refact`](https://github.com/mpickering/apply-refact) package, it uses the GHC API in order to transform source files given a list of refactorings to apply. Hlint directly calls the executable to apply the

@@ -102,7 +102,6 @@         Right v -> Just v  _noParen_ = id-_eval_ = id  withMain :: IO () -> IO () withMain act = do

@@ -6,7 +6,6 @@ (==>) = undefined  _noParen_ = id-_eval_ = id   ---------------------------------------------------------------------

@@ -102,7 +102,8 @@     - warn: {lhs: sortBy (flip (comparing f)), rhs: sortOn (Down . f)}     - warn: {lhs: sortBy (comparing f), rhs: sortOn f, side: notEq f fst && notEq f snd}     - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order}-    - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order}+    # This suggestion likely costs performance, see https://github.com/ndmitchell/hlint/issues/669#issuecomment-607154496+    # - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order}     - hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip}     - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on} @@ -142,6 +143,7 @@     - warn: {lhs: foldl f (head x) (tail x), rhs: foldl1 f x}     - warn: {lhs: foldr f (last x) (init x), rhs: foldr1 f x}     - warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"}+    - warn: {lhs: foldr (.) id l z, rhs: foldr ($) z l}     - warn: {lhs: span (not . p), rhs: break p}     - warn: {lhs: break (not . p), rhs: span p}     - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness}@@ -175,6 +177,7 @@     - hint: {lhs: 0 /= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null}     - hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"}     - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)}+    - hint: {lhs: "map f (fromMaybe [] x)", rhs: "maybe [] (map f) x"}     - warn: {lhs: not (elem x y), rhs: notElem x y}     - hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map}     - warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"}@@ -239,8 +242,8 @@     - warn: {lhs: foldMap id, rhs: fold}     - warn: {lhs: fold (fmap f x), rhs: foldMap f x}     - warn: {lhs: fold (map f x), rhs: foldMap f x}-    - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x}-    - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x}+    - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x, name: Fuse foldMap/fmap}+    - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x, name: Fuse foldMap/map}      # BY @@ -344,8 +347,6 @@     - warn: {lhs: if x then False else y, rhs: not x && y, side: notEq y True, name: Redundant if}     - warn: {lhs: if x then y else True, rhs: not x || y, side: notEq y False, name: Redundant if}     - warn: {lhs: not (not x), rhs: x, name: Redundant not}-    # warn "Too strict if": {lhs: if c then f x else f y, rhs: f (if c then x else y), note: IncreasesLaziness}-    # also breaks types, see #87      # ARROW @@ -414,6 +415,12 @@     - warn: {lhs: liftA, rhs: fmap}     - hint: {lhs: m >>= return . f, rhs: f <$> m}     - hint: {lhs: return . f =<< m, rhs: f <$> m}+    - warn: {lhs: fmap f x >>= g, rhs: x >>= g . f}+    - warn: {lhs: f <$> x >>= g, rhs: x >>= g . f}+    - warn: {lhs: x Data.Functor.<&> f >>= g, rhs: x >>= g . f}+    - warn: {lhs: g =<< fmap f x, rhs: g . f =<< x}+    - warn: {lhs: g =<< f <$> x, rhs: g . f =<< x}+    - warn: {lhs: g =<< (x Data.Functor.<&> f), rhs: g . f =<< x}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}@@ -443,8 +450,15 @@     - warn: {lhs: flip (=<<), rhs: (>>=)}     - hint: {lhs: \x -> f x >>= g, rhs: f Control.Monad.>=> g}     - hint: {lhs: \x -> f =<< g x, rhs: f Control.Monad.<=< g}+    - hint: {lhs: (>>= f) . g, rhs: f Control.Monad.<=< g}+    - hint: {lhs: (f =<<) . g, rhs: f Control.Monad.<=< g}     - warn: {lhs: a >> forever a, rhs: forever a}     - hint: {lhs: liftM2 id, rhs: ap}+    - warn: {lhs: liftA2 f (return x), rhs: fmap (f x)}+    - warn: {lhs: liftM2 f (pure x), rhs: fmap (f x)}+    - warn: {lhs: liftM2 f (return x), rhs: fmap (f x)}+    - warn: {lhs: fmap f (return x), rhs: return (f x)}+    - warn: {lhs: f <$> return x, rhs: return (f x)}     - warn: {lhs: mapM (uncurry f) (zip l m), rhs: zipWithM f l m}     - warn: {lhs: mapM_ (void . f), rhs: mapM_ f}     - warn: {lhs: forM_ x (void . f), rhs: forM_ x f}@@ -484,6 +498,9 @@     - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}     - warn: {lhs: foldr (<|>) empty, rhs: asum}     - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)}+    - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)}+    - warn: {lhs: fmap f (pure x), rhs: pure (f x)}+    - warn: {lhs: f <$> pure x, rhs: pure (f x)}     - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}     - hint: {lhs: m >>= pure . f, rhs: f <$> m}     - hint: {lhs: pure . f =<< m, rhs: f <$> m}@@ -518,8 +535,12 @@     - warn: {lhs: maybe Nothing Just, rhs: id, name: Redundant maybe}     - warn: {lhs: maybe False (const True), rhs: Data.Maybe.isJust}     - warn: {lhs: maybe True (const False), rhs: Data.Maybe.isNothing}-    - warn: {lhs: maybe False (== x), rhs: (== Just x)}-    - warn: {lhs: maybe True (/= x), rhs: (/= Just x)}+    - warn: {lhs: maybe False (x ==), rhs: (Just x ==)}+    - warn: {lhs: maybe True (x /=), rhs: (Just x /=)}+    - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x}+    - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x}+    - warn: {lhs: fromMaybe False, rhs: (Just True ==)}+    - warn: {lhs: fromMaybe True, rhs: (Just False /=)}     - warn: {lhs: not (isNothing x), rhs: isJust x}     - warn: {lhs: not (isJust x), rhs: isNothing x}     - warn: {lhs: "maybe [] (:[])", rhs: maybeToList}@@ -551,8 +572,6 @@     - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m}     - hint: {lhs: maybe Nothing id, rhs: join}     - hint: {lhs: maybe Nothing f x, rhs: f =<< x}-    - hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe}-    - hint: {lhs: maybe (f x) f y, rhs: f (Data.Maybe.fromMaybe x y), note: IncreasesLaziness, name: Too strict maybe}     - 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}@@ -652,8 +671,12 @@      - warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f}     - warn: {lhs: fmap f  Control.Monad.State.get, rhs: gets f}+    - warn: {lhs: f <$> Control.Monad.State.gets g, rhs: gets (f . g)}+    - warn: {lhs: fmap f (Control.Monad.State.gets g), rhs: gets (f . g)}     - warn: {lhs: f <$> Control.Monad.Reader.ask, rhs: asks f}     - warn: {lhs: fmap f Control.Monad.Reader.ask, rhs: asks f}+    - warn: {lhs: f <$> Control.Monad.Reader.asks g, rhs: asks (f . g)}+    - warn: {lhs: fmap f (Control.Monad.Reader.asks g), rhs: asks (f . g)}     - warn: {lhs: fst (runState m s), rhs: evalState m s}     - warn: {lhs: snd (runState m s), rhs: execState m s} @@ -742,6 +765,12 @@     - warn: {lhs: null x  , rhs: "False", side: isTuple x, name: Using null on tuple}     - warn: {lhs: length x, rhs: "1"    , side: isTuple x, name: Using length on tuple} +    # MAP++    - warn: {lhs: "Data.Map.fromList []", rhs: Data.Map.empty}+    - warn: {lhs: "Data.Map.Lazy.fromList []", rhs: Data.Map.Lazy.empty}+    - warn: {lhs: "Data.Map.Strict.fromList []", rhs: Data.Map.Strict.empty}+ - group:     name: lens     enabled: true@@ -811,8 +840,6 @@     - warn: {lhs: either (const False), rhs: any}     - warn: {lhs: either (const True), rhs: all}     - warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold}-    - warn: {lhs: Data.Maybe.fromMaybe False, rhs: or}-    - warn: {lhs: Data.Maybe.fromMaybe True, rhs: and}     - warn: {lhs: Data.Maybe.fromMaybe 0, rhs: sum}     - warn: {lhs: Data.Maybe.fromMaybe 1, rhs: product}     - warn: {lhs: Data.Maybe.fromMaybe empty, rhs: Data.Foldable.asum}@@ -831,7 +858,78 @@     - hint: {lhs: "[fst x, snd x]", rhs: Data.Bifoldable.biList x}     - hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness} +# hints that use the 'extra' library - group:+    name: extra+    enabled: false+    rules:+    - warn: {lhs: fmap concat (forM a b), rhs: concatForM a b}+    - warn: {lhs: concat <$> forM a b, rhs: concatForM a b}+    - warn: {lhs: fmap concat (forM_ a b), rhs: concatForM_ a b}+    - warn: {lhs: concat <$> forM_ a b, rhs: concatForM_ a b}+    - warn: {lhs: "maybe (pure ()) b a", rhs: "whenJust a b"}+    - warn: {lhs: "maybe (return ()) b a", rhs: "whenJust a b"}+    - warn: {lhs: "maybeM (pure ()) b a", rhs: "whenJustM a b"}+    - warn: {lhs: "maybeM (return ()) b a", rhs: "whenJustM a b"}+    - warn: {lhs: "if a then Just <$> b else pure Nothing", rhs: "whenMaybe a b"}+    - warn: {lhs: "maybe a b =<< c", rhs: "maybeM a b c"}+    - warn: {lhs: "maybeM a pure x", rhs: "fromMaybeM a b"}+    - warn: {lhs: "maybeM a return x", rhs: "fromMaybeM a b"}+    - warn: {lhs: "either a b =<< c", rhs: "eitherM a b c"}+    - warn: {lhs: "fold1M a b >> return ()", rhs: "fold1M_ a b"}+    - warn: {lhs: "fold1M a b >> pure ()", rhs: "fold1M_ a b"}+    - warn: {lhs: "flip concatMapM", rhs: "concatForM"}+    - warn: {lhs: "liftM mconcat (mapM a b)", rhs: "mconcatMapM a b"}+    - warn: {lhs: "ifM a b (return ())", rhs: "whenM a b"}+    - warn: {lhs: "ifM a (return ()) b", rhs: "unlessM a b"}+    - warn: {lhs: "ifM a (return True) b", rhs: "(||^) a b"}+    - warn: {lhs: "ifM a b (return False)", rhs: "(&&^) a b"}+    - warn: {lhs: "anyM id", rhs: "orM"}+    - warn: {lhs: "allM id", rhs: "andM"}+    - warn: {lhs: "either id id", rhs: "fromEither"}+    - warn: {lhs: "either (const Nothing) Just", rhs: "eitherToMaybe"}+    - warn: {lhs: "either (Left . a) Right", rhs: "mapLeft a"}+    - warn: {lhs: "atomicModifyIORef a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef_ a b"}+    - warn: {lhs: "atomicModifyIORef' a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef'_ a b"}+    - warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"}+    - warn: {lhs: "[minBound .. maxBound]", rhs: "enumerate"}+    - warn: {lhs: "zipWithFrom (,)", rhs: "zipFrom"}+    - warn: {lhs: "zip [i..]", rhs: "zipFrom i"}+    - warn: {lhs: "zipWith f [i..]", rhs: "zipWithFrom f i"}+    - warn: {lhs: "dropWhile isSpace", rhs: "trimStart"}+    - warn: {lhs: "dropWhileEnd isSpace", rhs: "trimEnd"}+    - warn: {lhs: "trimEnd (trimStart a)", rhs: "trim a"}+    - warn: {lhs: "map toLower", rhs: "lower"}+    - warn: {lhs: "map toUpper", rhs: "upper"}+    - warn: {lhs: "mergeBy compare", rhs: "merge"}+    - warn: {lhs: "breakEnd (not . a)", rhs: "spanEnd a"}+    - warn: {lhs: "spanEnd (not . a)", rhs: "breakEnd a"}+    - warn: {lhs: "mconcat (map a b)", rhs: "mconcatMap a b"}+    - warn: {lhs: "fromMaybe b (stripPrefix a b)", rhs: "dropPrefix a b"}+    - warn: {lhs: "fromMaybe b (stripSuffix a b)", rhs: "dropSuffix a b"}+    - warn: {lhs: "nubSortBy compare", rhs: "nubSort"}+    - warn: {lhs: "nubSortBy (compare `on` a)", rhs: "nubSortOn a"}+    - warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"}+    - warn: {lhs: "\\a -> (a, a)", rhs: "dupe"}+    - warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"}+    - warn: {lhs: "readFileEncoding utf8", rhs: "readFileUTF8"}+    - warn: {lhs: "withFile a ReadMode hGetContents'", rhs: "readFile' a"}+    - warn: {lhs: "readFileEncoding' utf8", rhs: "readFileUTF8'"}+    - warn: {lhs: "withBinaryFile a ReadMode hGetContents'", rhs: "readFileBinary' a"}+    - warn: {lhs: "writeFileEncoding utf8", rhs: "writeFileUTF8"}+    - warn: {lhs: "head $ x ++ [y]", rhs: "headDef y x"}+    - warn: {lhs: "last $ x : y", rhs: "lastDef x y"}+    - warn: {lhs: "drop 1", rhs: "drop1"}+    - warn: {lhs: "dropEnd 1", rhs: "dropEnd1"}++# hints that will be enabled in future+- group:+    name: future+    enabled: false+    rules:+    - warn: {lhs: return, rhs: pure}++- group:     name: dollar     enabled: false     imports:@@ -840,6 +938,18 @@     - warn: {lhs: a $ b $ c, rhs: a . b $ c}  - group:+    # These hints are same if all matched functions are monomorphic, or polymorphic, but don't have adhoc polymorphism+    name: monomorphic+    enabled: false+    imports:+    - package base+    rules:+    - warn: {lhs: if c then f x else f y, rhs: f (if c then x else y), note: IncreasesLaziness, name: Too strict if}+    - hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe}+    - hint: {lhs: maybe (f x) f y, rhs: f (Data.Maybe.fromMaybe x y), note: IncreasesLaziness, name: Too strict maybe}+++- group:     name: teaching     enabled: false     imports:@@ -927,6 +1037,7 @@ # 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)+# yes = (foo . bar . when) (not . null $ asdf) -- (foo . bar) (unless (null asdf)) # yes = id 1 -- 1 # yes = case concat (map f x) of [] -> [] -- concatMap f x # yes = [v | v <- xs] -- xs@@ -946,10 +1057,13 @@ # test = \ a -> f a >>= \ b -> return (a, b) # fooer input = catMaybes . map Just $ input -- mapMaybe Just # yes = mapMaybe id -- catMaybes+# foo = magic . isLeft $ fmap f x -- magic (isLeft x)+# foo = (bar . baz . magic . isRight) (fmap f x) -- (bar . baz . magic) (isRight x) # main = print $ map (\_->5) [2,3,5] -- const 5 # main = head $ drop n x -- x !! max 0 n # main = head $ drop (-3) x -- x # main = head $ drop 2 x -- x !! 2+# main = foo . bar . baz . head $ drop 2 x -- (foo . bar . baz) (x !! 2) # main = drop 0 x -- x # main = take 0 x -- [] # main = take (-5) x -- []@@ -959,7 +1073,8 @@ # main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l # main = fst (splitAt n l) -- take n l # main = snd $ splitAt n l -- drop n l-# main = map $ \ d -> ([| $d |], [| $d |])+# main = map $ \ d -> ([| $d |], [| $d |]) @NoRefactor: apply-refact requires TemplateHaskell pragma+# {-# LANGUAGE TemplateHaskell #-}; main = map $ \ d -> ([| $d |], [| $d |]) # pairs (x:xs) = map (x,) xs ++ pairs xs # {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ??? # {-# HLINT ignore foo #-};foo = map f (map g x) -- @Ignore ???@@ -1007,6 +1122,7 @@ # no = sequenceA (pure a) # {-# LANGUAGE QuasiQuotes #-}; no = f (\url -> [hamlet|foo @{url}|]) # yes = f ((,) x) -- (x,)+# yes = f ((,) (2 + 3)) -- (2 + 3,) # instance Class X where method = map f (map g x) -- map (f . g) x # instance Eq X where x == y = compare x y == EQ @@ -1045,4 +1161,11 @@ # foo = typeOf (undefined :: Foo Int) -- typeRep (Proxy :: Proxy (Foo Int)) # foo = typeOf (undefined :: a) -- typeRep (Proxy :: Proxy a) # {-# RULES "Id-fmap-id" forall (x :: Id a). fmap id x = x #-}+# import Data.Map (fromList) \+# fromList [] -- Data.Map.empty+# import Data.Map.Lazy (fromList) \+# fromList [] -- Data.Map.Lazy.empty+# import Data.Map.Strict (fromList) \+# fromList [] -- Data.Map.Strict.empty+# test953 = for [] $ \n -> bar n >>= \case {Just n  -> pure (); Nothing -> baz n} @NoRefactor # </TEST>

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.2.11+version:            3.0 license:            BSD3 license-file:       LICENSE category:           Development@@ -27,7 +27,7 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.8.1, GHC==8.6.5, GHC==8.4.4+tested-with:        GHC==8.10.1, GHC==8.8.3, GHC==8.6.5  source-repository head     type:     git@@ -60,23 +60,23 @@         cpphs >= 1.20.1,         cmdargs >= 0.10,         yaml >= 0.5.0,-        haskell-src-exts >= 1.21 && < 1.24,-        haskell-src-exts-util >= 0.2.5,         uniplate >= 1.5,         ansi-terminal >= 0.6.2,-        extra >= 1.6.6,+        extra >= 1.7.1,         refact >= 0.3,         aeson >= 1.1.2.0,-        filepattern >= 0.1.1,-        ghc-lib-parser-ex == 8.8.5.*-    if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)-        build-depends:-          ghc == 8.8.*,-          ghc-boot-th,-          ghc-boot+        filepattern >= 0.1.1++    if !flag(ghc-lib) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0)+      build-depends:+        ghc == 8.10.*,+        ghc-boot-th,+        ghc-boot     else-        build-depends:-          ghc-lib-parser == 8.8.*+      build-depends:+          ghc-lib-parser == 8.10.*+    build-depends:+        ghc-lib-parser-ex >= 8.10.0.5 && < 8.10.1      if flag(gpl)         build-depends: hscolour >= 1.21@@ -86,13 +86,13 @@     hs-source-dirs:     src     exposed-modules:         Language.Haskell.HLint-        Language.Haskell.HLint3-        Language.Haskell.HLint4     other-modules:         Paths_hlint         Apply         CmdLine         Grep+        Extension+        Fixity         HLint         HsColour         Idea@@ -116,9 +116,6 @@         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@@ -128,10 +125,6 @@         GHC.Util.Unify          HSE.All-        HSE.Match-        HSE.Scope-        HSE.Type-        HSE.Util         Hint.All         Hint.Bracket         Hint.Comment@@ -152,7 +145,6 @@         Hint.Smell         Hint.Type         Hint.Unsafe-        Hint.Util         Test.All         Test.Annotations         Test.InputOutput

@@ -6,6 +6,7 @@ import HSE.All import Hint.All import GHC.Util+import Data.Generics.Uniplate.Data import Idea import Data.Tuple.Extra import Data.Either@@ -14,7 +15,7 @@ import Data.Ord import Config.Type import Config.Haskell-import HsSyn+import GHC.Hs import qualified SrcLoc as GHC import qualified Data.HashSet as Set import Prelude@@ -24,7 +25,7 @@ applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea] applyHintFile flags s file src = do     res <- parseModuleApply flags s file src-    return $ case res of+    pure $ case res of         Left err -> [err]         Right m -> executeHints s [m] @@ -33,7 +34,7 @@ applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] applyHintFiles flags s files = do     (err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files-    return $ err ++ executeHints s ms+    pure $ err ++ executeHints s ms   -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.@@ -48,32 +49,29 @@  applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] applyHintsReal settings hints_ ms = concat $-    [ 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 (maybeToList $ declName d) $ decHints' d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]-    | (nm, m) <- mns-    , let classifiers = cls ++ mapMaybe readPragma (universeBi (hseModule m)) ++ concatMap readComment (ghcComments m)+    [ map (classify classifiers . removeRequiresExtensionNotes m) $+        order [] (hintModule hints settings nm' m) `merge`+        concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]+    | m <- ms+    , let classifiers = cls ++ mapMaybe readPragma (universeBi (ghcModule m)) ++ concatMap readComment (ghcComments m)     , seq (length classifiers) True -- to force any errors from readPragma or readComment-    , let decHints = hintDecl hints settings nm m -- partially apply     , (nm',m') <- mns'-    , let decHints' = hintDecl' hints settings nm' m' -- partially apply-    , let order n = map (\i -> i{ideaModule= f $ moduleName (hseModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn ideaSpan+    , let decHints = hintDecl hints settings nm' m' -- partially apply+    , let order n = map (\i -> i{ideaModule = f $ modName (ghcModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn ideaSpan     , let merge = mergeBy (comparing ideaSpan)] ++-    [map (classify cls) (hintModules hints settings mns)]+    [map (classify cls) (hintModules hints settings mns')]     where         f = nubOrd . filter (/= "")         cls = [x | SettingClassify x <- settings]-        mns = map (\x -> (scopeCreate (hseModule x), x)) ms-        mns' = map (\x -> (scopeCreate' (GHC.unLoc $ ghcModule x), x)) ms+        mns' = map (\x -> (scopeCreate (GHC.unLoc $ ghcModule x), x)) ms         hints = (if length ms <= 1 then noModules else id) hints_         noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}  -- If the hint has said you RequiresExtension Foo, but Foo is enabled, drop the note-removeRequiresExtensionNotes :: Module_ -> Idea -> Idea+removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x}     where-        exts = Set.fromList $ map fromNamed $ moduleExtensions m+        exts = Set.fromList $ concatMap snd $ langExts $ pragmas $ ghcAnnotations m         keep (RequiresExtension x) = not $ x `Set.member` exts         keep _ = True @@ -87,11 +85,19 @@ parseModuleApply flags s file src = do     res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src     case res of-      Right r -> return $ Right r+      Right r -> pure $ Right r       Left (ParseError sl msg ctxt) ->-            return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []+            pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing []+    where+        -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works+        -- try and tidy up things like "parse error (mismatched brackets)" to not look silly+        adjustMessage :: String -> String+        adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x) +        dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs+        dropBrackets xs = xs + -- | Find which hints a list of settings implies. allHints :: [Setting] -> Hint allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin@@ -101,10 +107,11 @@  -- | Given some settings, make sure the severity field of the Idea is correct. classify :: [Classify] -> Idea -> Idea-classify xs i =  let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s}+classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s}     where         -- figure out if we need to change the severity         f :: Idea -> Severity -> Classify -> Severity-        f i r c | classifyHint c ~= [ideaHint i] && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c+        f i r c | classifyHint c ~~= ideaHint i && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c                 | otherwise = r-        x ~= y = null x || x `elem` y+        x ~= y = x == "" || x `elem` y+        x  ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y)

@@ -13,13 +13,15 @@ import Data.Aeson (ToJSON(..), (.=), encode, object) import Data.Char (toUpper) import Data.Text (Text)-import Language.Haskell.Exts.SrcLoc (SrcSpan(..))  import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as C8  import Idea (Idea(..), Severity(..)) +import qualified SrcLoc as GHC+import qualified GHC.Util as GHC+ data Issue = Issue     { issueType :: Text     , issueCheckName :: Text@@ -119,11 +121,11 @@     points Warning = 5 * basePoints     points Error = 10 * basePoints -fromSrcSpan :: SrcSpan -> Location-fromSrcSpan SrcSpan{..} = Location+fromSrcSpan :: GHC.SrcSpan -> Location+fromSrcSpan GHC.SrcSpan{..} = Location     (locationFileName srcSpanFilename)-    (Position srcSpanStartLine srcSpanStartColumn)-    (Position srcSpanEndLine srcSpanEndColumn)+    (Position srcSpanStartLine' srcSpanStartColumn)+    (Position srcSpanEndLine' srcSpanEndColumn)   where     locationFileName ('.':'/':x) = x     locationFileName x = x

@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-}-{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}+{-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-}  module CmdLine(     Cmd(..), getCmd,@@ -8,14 +8,17 @@     ) where  import Control.Monad.Extra+import Control.Exception.Extra import qualified Data.ByteString as BS import Data.Char-import Data.List+import Data.List.Extra import Data.Maybe import Data.Functor import HSE.All(CppFlags(..))-import Language.Haskell.Exts(defaultParseMode, baseLanguage)-import Language.Haskell.Exts.Extension+import GHC.LanguageExtensions.Type+import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx+import DynFlags hiding (verbosity)+ import Language.Preprocessor.Cpphs import System.Console.ANSI(hSupportsANSI) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..))@@ -32,6 +35,7 @@  import EmbedData import Util+import Extension import Paths_hlint import Data.Version import Prelude@@ -47,29 +51,28 @@     CmdMain{} -> dataDir =<< path =<< git =<< extension cmd     CmdGrep{} -> path =<< extension cmd     CmdTest{} -> dataDir cmd-    _ -> return cmd     where-        path cmd = return $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd-        extension cmd = return $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd+        path cmd = pure $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd+        extension cmd = pure $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd         dataDir cmd-            | cmdDataDir cmd  /= "" = return cmd+            | cmdDataDir cmd  /= "" = pure cmd             | otherwise = do                 x <- getDataDir                 b <- doesDirectoryExist x-                if b then return cmd{cmdDataDir=x} else do+                if b then pure cmd{cmdDataDir=x} else do                     exe <- getExecutablePath-                    return cmd{cmdDataDir = takeDirectory exe </> "data"}+                    pure cmd{cmdDataDir = takeDirectory exe </> "data"}         git cmd             | cmdGit cmd = do                 mgit <- findExecutable "git"                 case mgit of-                    Nothing -> error "Could not find git"+                    Nothing -> errorIO "Could not find git"                     Just git -> do                         let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++                                    map ("*." ++) (cmdExtension cmd)                         files <- readProcess git args ""-                        return cmd{cmdFiles = cmdFiles cmd ++ lines files}-            | otherwise = return cmd+                        pure cmd{cmdFiles = cmdFiles cmd ++ lines files}+            | otherwise = pure cmd   exitWithHelp :: IO a@@ -95,7 +98,6 @@         {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given         ,cmdReports :: [FilePath]        -- ^ where to generate reports         ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given-        ,cmdWithHints :: [String]        -- ^ hints that are given on the command line         ,cmdWithGroups :: [String]       -- ^ groups that are given on the command line         ,cmdGit :: Bool                  -- ^ use git ls-files to find files         ,cmdColor :: ColorMode           -- ^ color the result@@ -143,14 +145,10 @@         ,cmdGivenHints :: [FilePath]     -- ^ which settings files were explicitly given         ,cmdDataDir :: FilePath          -- ^ the data directory         ,cmdReports :: [FilePath]        -- ^ where to generate reports-        ,cmdWithHints :: [String]        -- ^ hints that are given on the command line         ,cmdTempDir :: FilePath          -- ^ temporary directory to put the files in         ,cmdQuickCheck :: Bool         ,cmdTypeCheck :: Bool-        }-    | CmdHSE-        {cmdFiles :: [FilePath]-        ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")+        ,cmdWithRefactor :: FilePath         }     deriving (Data,Typeable,Show) @@ -159,7 +157,6 @@         {cmdFiles = def &= args &= typ "FILE/DIR"         ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"         ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"-        ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use"         ,cmdWithGroups = nam_ "with-group" &= typ "GROUP" &= help "Extra hint groups to use"         ,cmdGit = nam "git" &= help "Run on files tracked by git"         ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)"@@ -204,8 +201,6 @@                    ,""                    ,"To check all Haskell files in 'src' and generate a report type:"                    ,"  hlint src --report"]-    ,CmdHSE-        {} &= explicit &= name "hse"     ] &= program "hlint" &= verbosity     &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2020")     where@@ -213,42 +208,40 @@         nam_ xs = def &= explicit &= name xs  -- | Where should we find the configuration files?---   * If someone passes cmdWithHints, only look at files they explicitly request---   * If someone passes an explicit hint name, automatically merge in data/hlint.yaml+--   Either we use the implicit search, or we follow the cmdGivenHints --   We want more important hints to go last, since they override cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)] cmdHintFiles cmd = do-    let explicit1 = [hlintYaml | null $ cmdWithHints cmd]-    let explicit2 = cmdGivenHints cmd-    bad <- filterM (notM . doesFileExist) explicit2-    let explicit2' = map (,Nothing) explicit2+    let explicit = cmdGivenHints cmd+    bad <- filterM (notM . doesFileExist) explicit     when (bad /= []) $         fail $ unlines $ "Failed to find requested hint files:" : map ("  "++) bad-    if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2' else do++    -- if the user has given any explicit hints, ignore the local ones+    implicit <- if explicit /= [] then pure Nothing else do         -- we follow the stylish-haskell config file search policy         -- 1) current directory or its ancestors; 2) home directory         curdir <- getCurrentDirectory         -- Ignores home directory when it isn't present.-        home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ return [])-        implicit <- findM doesFileExist $+        home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ pure [])+        findM doesFileExist $             map (</> ".hlint.yaml") (ancestors curdir ++ home) -- to match Stylish Haskell-            ++ ["HLint.hs"] -- the default in HLint 1.*-        return $ explicit1 ++ map (,Nothing) (maybeToList implicit) ++ explicit2'+    pure $ hlintYaml : map (,Nothing) (maybeToList implicit ++ explicit)     where         ancestors = init . map joinPath . reverse . inits . splitPath -cmdExtensions :: Cmd -> (Language, [Extension])+cmdExtensions :: Cmd -> (Maybe Language, [Extension]) cmdExtensions = getExtensions . cmdLanguage   cmdCpp :: Cmd -> CppFlags cmdCpp cmd     | cmdCppSimple cmd = CppSimple-    | EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions+    | Cpp `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions         {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd}         ,includes = cmdCppInclude cmd         ,preInclude = cmdCppFile cmd-        ,defines = ("__HLINT__","1") : [(a,drop 1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]+        ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x]         }     | otherwise = NoCpp @@ -256,8 +249,8 @@ -- | Determines whether to use colour or not. cmdUseColour :: Cmd -> IO Bool cmdUseColour cmd = case cmdColor cmd of-  Always -> return True-  Never  -> return False+  Always -> pure True+  Never  -> pure False   Auto   -> hSupportsANSI stdout  @@ -285,23 +278,23 @@ getFile :: (FilePath -> Bool) -> [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath] getFile _ path _ (Just tmpfile) "-" =     -- make sure we don't reencode any Unicode-    BS.getContents >>= BS.writeFile tmpfile >> return [tmpfile]-getFile _ path _ Nothing "-" = return ["-"]+    BS.getContents >>= BS.writeFile tmpfile >> pure [tmpfile]+getFile _ path _ Nothing "-" = pure ["-"] getFile _ [] exts _ file = exitMessage $ "Couldn't find file: " ++ file getFile ignore (p:ath) exts t file = do     isDir <- doesDirectoryExist $ p <\> file     if isDir then do         let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y))             avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x-        xs <- listFilesInside (return . not . avoidDir) $ p <\> file-        return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x]+        xs <- listFilesInside (pure . not . avoidDir) $ p <\> file+        pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x]      else do         isFil <- doesFileExist $ p <\> file-        if isFil then return [p <\> file]+        if isFil then pure [p <\> file]          else do             res <- getModule p exts file             case res of-                Just x -> return [x]+                Just x -> pure [x]                 Nothing -> getFile ignore ath exts t file  @@ -313,28 +306,22 @@         isMod _ = False         pre = path <\> joinPath xs -        f [] = return Nothing+        f [] = pure Nothing         f (x:xs) = do             let s = pre <.> x             b <- doesFileExist s-            if b then return $ Just s else f xs-getModule _ _ _ = return Nothing+            if b then pure $ Just s else f xs+getModule _ _ _ = pure Nothing  -getExtensions :: [String] -> (Language, [Extension])-getExtensions args = (lang, foldl f (if null langs then parseExtensions else []) exts)+getExtensions :: [String] -> (Maybe Language, [Extension])+getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts)     where-        lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls+        lang = if null langs then Nothing else Just $ fromJust $ lookup (last langs) ls         (langs, exts) = partition (isJust . flip lookup ls) args-        ls = [(show x, x) | x <- knownLanguages]+        ls = [(show x, x) | x <- [Haskell98, Haskell2010]]          f a "Haskell98" = []-        f a ('N':'o':x) | Just x <- readExtension x = delete x a-        f a x | Just x <- readExtension x = x : delete x a-        f a x = UnknownExtension x : delete (UnknownExtension x) a---readExtension :: String -> Maybe Extension-readExtension x = case classifyExtension x of-    UnknownExtension _ -> Nothing-    x -> Just x+        f a ('N':'o':x) | Just x <- GhclibParserEx.readExtension x = delete x a+        f a x | Just x <- GhclibParserEx.readExtension x = x : delete x a+        f a x = a -- Ignore unknown extension.

@@ -1,12 +1,21 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}  -- | Given a file, guess settings from it by looking at the hints. module Config.Compute(computeSettings) where  import HSE.All+import GHC.Util import Config.Type-import Config.Haskell-import Data.Monoid+import Fixity+import Data.Generics.Uniplate.Data+import GHC.Hs hiding (Warning)+import RdrName+import Name+import Bag+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import SrcLoc import Prelude  @@ -17,46 +26,55 @@     x <- parseModuleEx flags file Nothing     case x of         Left (ParseError sl msg _) ->-            return ("# Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        Right (ModuleEx m _ _ _) -> do-            let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)-                r = concatMap (readSetting mempty) xs-                s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting r ++ ["# no hints found" | null xs]-            return (s,r)+            pure ("# Parse error " ++ showSrcSpan' sl ++ ": " ++ msg, [])+        Right ModuleEx{ghcModule=m} -> do+            let xs = concatMap findSetting (hsmodDecls $ unLoc m)+                s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs]+            pure (s,xs) + renderSetting :: Setting -> [String]+-- Only need to convert the subset of Setting we generate renderSetting (SettingMatchExp HintRule{..}) =-    ["- warn: {lhs: " ++ show (prettyPrint hintRuleLHS) ++ ", rhs: " ++ show (prettyPrint hintRuleRHS) ++ "}"]-renderSetting (Infix x) = ["- infix: " ++ show (prettyPrint (toInfixDecl x))]+    ["- warn: {lhs: " ++ show (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"]+renderSetting (Infix x) =+    ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)] renderSetting _ = [] -findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_]-findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs]-findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod-findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind]-findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod-findSetting _ x@InfixDecl{} = [x]-findSetting _ _ = []+findSetting :: LHsDecl GhcPs -> [Setting]+findSetting (L _ (ValD _ x)) = findBind x+findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =+    concatMap (findBind . unLoc) $ bagToList cid_binds+findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x+findSetting x = []  --- given a result function name, a list of variables, a body expression, give some hints-findExp :: QName S -> [String] -> Exp_ -> [Decl_]-findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod-                                  | otherwise = []-    where ps2 = [x | PVar_ x <- map view ps]-findExp name vs Var{} = []-findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint")+findBind :: HsBind GhcPs -> [Setting]+findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs+findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches+findBind _ = [] -findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing]+findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]+findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]})+    = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []+    where ps = [occNameString $ occName $ unLoc x | L _ (VarPat _ x) <- m_pats]+findExp name vs HsLam{} = []+findExp name vs HsVar{} = []+findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $+    HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint"++findExp name vs bod = [SettingMatchExp $+        HintRule Warning defaultHintName []+        mempty (extendInstances lhs) (extendInstances $ fromParen' rhs) Nothing]     where-        lhs = g $ transform f bod-        rhs = apps $ Var an name : map snd rep+        lhs = fromParen' $ noLoc $ transform f bod+        rhs = apps' $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep -        rep = zip vs $ map (toNamed . return) ['a'..]-        f xx | Var_ x <- view xx, Just y <- lookup x rep = y-        f (InfixApp _ x dol y) | isDol dol = App an x (paren y)+        rep = zip vs $ map (mkVar . pure) ['a'..]+        f (HsVar _ x) | Just y <- lookup (occNameString $ occName $ unLoc x) rep = y+        f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y         f x = x -        g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o-        g o@App{} = o-        g o = paren o++mkVar :: String -> HsExpr GhcPs+mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc

@@ -1,12 +1,9 @@-{-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Config.Haskell(     readPragma,-    readComment,-    readSetting,-    readFileConfigHaskell+    readComment     ) where -import HSE.All import Data.Char import Data.List.Extra import Text.Read.Extra(readMaybe)@@ -16,79 +13,38 @@ import Util import Prelude -import qualified HsSyn as GHC-import qualified BasicTypes as GHC import GHC.Util-import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances  import SrcLoc as GHC+import GHC.Hs.Extension+import GHC.Hs.Decls hiding (SpliceDecl)+import GHC.Hs.Expr hiding (Match)+import GHC.Hs.Lit+import FastString import ApiAnnotation---addInfix :: ParseFlags -> ParseFlags-addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]--------------------------------------------------------------------------- READ A SETTINGS FILE--readFileConfigHaskell :: FilePath -> Maybe String -> IO [Setting]-readFileConfigHaskell file contents = do-    let flags = addInfix defaultParseFlags-    res <- parseModuleEx flags file contents-    case res of-        Left (ParseError sl msg err) ->-            error $ "Config parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err-        Right modEx@(ModuleEx m _ _ _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment (ghcComments modEx))----- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.---   Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.-readSettings :: Module_ -> [Setting]-readSettings m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $-                       [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m---readSetting :: Scope -> Decl_ -> [Setting]-readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])-    | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =-        let (a,b) = readSide $ childrenBi bind in-        let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed in-        [SettingMatchExp $-         HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b-        -- Todo : Replace these with "proper" GHC expressions.-         (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing]-    | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]-    where-        names = filter (not . null) $ getNames pats bod-        names2 = ["" | null names] ++ names--readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = []-readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y]-readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind]-readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs-readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing]-readSetting s x@InfixDecl{} = map Infix $ getFixity x-readSetting s x = errorOn x "bad hint"+import OccName+import Outputable   -- | Read an {-# ANN #-} pragma and determine if it is intended for HLint. --   Return Nothing if it is not an HLint pragma, otherwise what it means.-readPragma :: Annotation S -> Maybe Classify-readPragma o = case o of-    Ann _ name x -> f (fromNamed name) x-    TypeAnn _ name x -> f (fromNamed name) x-    ModuleAnn _ x -> f "" x+readPragma :: AnnDecl GhcPs -> Maybe Classify+readPragma (HsAnnotation _ _ provenance expr) = f expr     where-        f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s =+        name = case provenance of+            ValueAnnProvenance (L _ x) -> occNameString $ occName x+            TypeAnnProvenance (L _ x) -> occNameString $ occName x+            ModuleAnnProvenance -> ""++        f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s =                 case getSeverity a of-                    Nothing -> errorOn o "bad classify pragma"+                    Nothing -> errorOn expr "bad classify pragma"                     Just severity -> Just $ Classify severity (trimStart b) "" name             where (a,b) = break isSpace $ trimStart $ drop 6 s-        f name (Paren _ x) = f name x-        f name (ExpTypeSig _ x _) = f name x-        f _ _ = Nothing-+        f (L _ (HsPar _ x)) = f x+        f (L _ (ExprWithTySig _ x _)) = f x+        f _ = Nothing+readPragma _ = Nothing  readComment :: GHC.Located AnnotationComment -> [Classify] readComment c@(L pos AnnBlockComment{})@@ -117,60 +73,15 @@ readComment _ = []  -readSide :: [Decl_] -> (Maybe Exp_, [Note])-readSide = foldl f (Nothing,[])-    where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes)-          f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes)-          f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note)-          f _ x = errorOn x "bad side condition"--          g (Lit _ (String _ x _)) = [Note x]-          g (List _ xs) = concatMap g xs-          g x = case fromApps x of-              [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness]-              [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness]-              [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a]-              [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b]-              [con -> Just "RequiresExtension",con -> Just a] -> [RequiresExtension a]-              _ -> errorOn x "bad note"--          con :: Exp_ -> Maybe String-          con c@Con{} = Just $ prettyPrint c; con _ = Nothing-          var c@Var{} = Just $ prettyPrint c; var _ = Nothing----- Note: Foo may be ("","Foo") or ("Foo",""), return both-readFuncs :: Exp_ -> [(String, String)]-readFuncs (App _ x y) = readFuncs x ++ readFuncs y-readFuncs (Lit _ (String _ "" _)) = [("","")]-readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)]-readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)]-readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)]-readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]-readFuncs x = errorOn x "bad classification rule"---getNames :: [Pat_] -> Exp_ -> [String]-getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps-getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names-    where-        lnames = map f $ childrenS lhs-        rnames = map f $ childrenS rhs-        names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames-        f (Ident _ x) = x-        f (Symbol _ x) = x-getNames _ _ = []---errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b-errorOn val msg = exitMessageImpure $-    showSrcLoc (getPointLoc $ ann val) +++errorOn :: Outputable a => Located a -> String -> b+errorOn (L pos val) msg = exitMessageImpure $+    showSrcSpan' pos ++     ": Error while reading hint file, " ++ msg ++ "\n" ++-    prettyPrint val+    unsafePrettyPrint val  errorOnComment :: GHC.Located AnnotationComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $     let isMultiline = isCommentMultiline c in-    showSrcLoc (ghcSrcLocToHSE $ GHC.srcSpanStart s) +++    showSrcSpan' s ++     ": Error while reading hint file, " ++ msg ++ "\n" ++     (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")

@@ -2,7 +2,8 @@ module Config.Read(readFilesConfig) where  import Config.Type-import Config.Haskell+import Control.Monad+import Control.Exception.Extra import Config.Yaml import Data.List.Extra import System.FilePath@@ -10,8 +11,11 @@  readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting] readFilesConfig files = do-        yaml <- mapM (uncurry readFileConfigYaml) yaml-        haskell <- mapM (uncurry readFileConfigHaskell) haskell-        return $ concat haskell ++ settingsFromConfigYaml yaml-    where-        (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files+    let (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files+    unless (null haskell) $+        errorIO $ "HLint 2.3 and beyond cannot use Haskell configuration files.\n" +++                  "Tried to use: " ++ show haskell ++ "\n" +++                  "Convert it to .yaml file format, following the example at\n" +++                  "  <https://github.com/ndmitchell/hlint/blob/master/data/hlint.yaml>"+    yaml <- mapM (uncurry readFileConfigYaml) yaml+    pure $ settingsFromConfigYaml yaml

@@ -5,12 +5,13 @@     defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType     ) where -import HSE.All import Data.Char import Data.List.Extra import Prelude -import qualified HsSyn++import qualified GHC.Hs+import Fixity import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances @@ -40,7 +41,7 @@     = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).     | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not.     | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply.-    | Error -- ^ Available as a setting for the user.+    | Error -- ^ Available as a setting for the user. Only parse errors have this setting by default.       deriving (Eq,Ord,Show,Read,Bounded,Enum)  @@ -94,16 +95,12 @@ data HintRule = HintRule     {hintRuleSeverity :: Severity -- ^ Default severity for the hint.     ,hintRuleName :: String -- ^ Name for the hint.-    ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.-    ,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS-    ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS-    ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.     ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.+    ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates (GHC parse tree).     -- We wrap these GHC elements in 'HsExtendInstances' in order that we may derive 'Show'.-    ,hintRuleGhcScope :: HsExtendInstances Scope' -- ^ Module scope in which the hint operates (GHC parse tree).-    ,hintRuleGhcLHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree).-    ,hintRuleGhcRHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree).-    ,hintRuleGhcSide :: Maybe (HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs))  -- ^ Side condition (GHC parse tree).+    ,hintRuleLHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ LHS (GHC parse tree).+    ,hintRuleRHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ RHS (GHC parse tree).+    ,hintRuleSide :: Maybe (HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs))  -- ^ Side condition (GHC parse tree).     }     deriving Show @@ -136,5 +133,5 @@     | SettingArgument String -- ^ Extra command-line argument     | SettingSmell SmellType Int     | Builtin String -- use a builtin hint set-    | Infix Fixity+    | Infix FixityInfo       deriving Show

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}  module Config.Yaml(@@ -18,30 +19,39 @@ import qualified Data.Vector as V import qualified Data.ByteString.Char8 as BS import qualified Data.HashMap.Strict as Map-import HSE.All hiding (Rule, String)+import Data.Generics.Uniplate.Data+import HSE.All+import Fixity+import Extension+import Module import Data.Functor import Data.Semigroup import Timing-import Util import Prelude +import Bag import qualified Lexer as GHC import qualified ErrUtils import qualified Outputable-import qualified HsSyn-import GHC.Util (baseDynFlags, Scope',scopeCreate')+import GHC.Hs+import SrcLoc+import qualified RdrName as GHC+import qualified OccName as GHC+import GHC.Util (baseDynFlags, Scope,scopeCreate) import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Data.Char + -- | Read a config file in YAML format. Takes a filename, and optionally the contents. --   Fails if the YAML doesn't parse or isn't valid HLint YAML readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml readFileConfigYaml file contents = timedIO "Config" file $ do     val <- case contents of         Nothing -> decodeFileEither file-        Just src -> return $ decodeEither' $ BS.pack src+        Just src -> pure $ decodeEither' $ BS.pack src     case val of         Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n  " ++ displayException e-        Right v -> return v+        Right v -> pure v   ---------------------------------------------------------------------@@ -57,15 +67,13 @@  data Package = Package     {packageName :: String-    ,packageModules :: [ImportDecl S]-    ,packageGhcModules :: [HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs)]+    ,packageModules :: [HsExtendInstances (LImportDecl GhcPs)]     } deriving Show  data Group = Group     {groupName :: String     ,groupEnabled :: Bool-    ,groupImports :: [Either String (ImportDecl S)] -- Left for package imports-    ,groupGhcImports :: [Either String (HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs))]+    ,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]     ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty     } deriving Show @@ -99,11 +107,11 @@         dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")  parseArray :: Val -> Parser [Val]-parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWith (\i x -> addVal (show i) x v) [0..] $ V.toList xs-parseArray v = return [v]+parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWithFrom (\i x -> addVal (show i) x v) 0 $ V.toList xs+parseArray v = pure [v]  parseObject :: Val -> Parser (Map.HashMap T.Text Value)-parseObject (getVal -> Object x) = return x+parseObject (getVal -> Object x) = pure x parseObject v = parseFail v "Expected an Object"  parseObject1 :: Val -> Parser (String, Val)@@ -114,7 +122,7 @@         _ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp)  parseString :: Val -> Parser String-parseString (getVal -> String x) = return $ T.unpack x+parseString (getVal -> String x) = pure $ T.unpack x parseString v = parseFail v "Expected a String"  parseInt :: Val -> Parser Int@@ -125,11 +133,11 @@ parseArrayString = parseArray >=> mapM parseString  maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)-maybeParse parseValue Nothing = return Nothing+maybeParse parseValue Nothing = pure Nothing maybeParse parseValue (Just value) = Just <$> parseValue value  parseBool :: Val -> Parser Bool-parseBool (getVal -> Bool b) = return b+parseBool (getVal -> Bool b) = pure b parseBool v = parseFail v "Expected a Bool"  parseField :: String -> Val -> Parser Val@@ -137,14 +145,14 @@     x <- parseFieldOpt s v     case x of         Nothing -> parseFail v $ "Expected a field named " ++ s-        Just v -> return v+        Just v -> pure v  parseFieldOpt :: String -> Val -> Parser (Maybe Val) parseFieldOpt s v = do     mp <- parseObject v     case Map.lookup (T.pack s) mp of-        Nothing -> return Nothing-        Just x -> return $ Just $ addVal s x v+        Nothing -> pure Nothing+        Just x -> pure $ Just $ addVal s x v  allowFields :: Val -> [String] -> Parser () allowFields v allow = do@@ -153,29 +161,22 @@     when (bad /= []) $         parseFail v $ "Not allowed keys: " ++ unwords bad -parseHSE :: (ParseMode -> String -> ParseResult v) -> Val -> Parser v-parseHSE parser v = do-    x <- parseString v-    case parser defaultParseMode{extensions=configExtensions} x of-        ParseOk x -> return x-        ParseFailed loc s ->-          parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n  " ++ x--parseGHC :: (ParseMode -> String -> GHC.ParseResult v) -> Val -> Parser v+parseGHC :: (ParseFlags -> String -> GHC.ParseResult v) -> Val -> Parser v parseGHC parser v = do     x <- parseString v-    case parser defaultParseMode{extensions=configExtensions} x of-        GHC.POk _ x -> return x-        GHC.PFailed _ loc err ->-          let msg = Outputable.showSDoc baseDynFlags $-                ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)+    case parser defaultParseFlags{extensions=configExtensions} x of+        GHC.POk _ x -> pure x+        GHC.PFailed ps ->+          let (_, errs) = GHC.getMessages ps baseDynFlags+              errMsg = head (bagToList errs)+              msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg           in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x  --------------------------------------------------------------------- -- YAML TO DATA TYPE  instance FromJSON ConfigYaml where-    parseJSON Null = return mempty+    parseJSON Null = pure mempty     parseJSON x = parseConfigYaml $ newVal x  parseConfigYaml :: Val -> Parser ConfigYaml@@ -197,15 +198,14 @@ parsePackage :: Val -> Parser Package parsePackage v = do     packageName <- parseField "name" v >>= parseString-    packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)-    packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode)+    packageModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode)     allowFields v ["name","modules"]-    return Package{..}+    pure Package{..}  parseFixity :: Val -> Parser [Setting]-parseFixity v = parseArray v >>= concatMapM (parseHSE parseDeclWithMode >=> f)+parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f)     where-        f x@InfixDecl{} = return $ map Infix $ getFixity x+        f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x         f _ = parseFail v "Expected fixity declaration"  parseSmell :: Val -> Parser [Setting]@@ -213,59 +213,48 @@   smellName <- parseField "type" v >>= parseString   smellType <- require v "Expected SmellType"  $ getSmellType smellName   smellLimit <- parseField "limit" v >>= parseInt-  return [SettingSmell smellType smellLimit]+  pure [SettingSmell smellType smellLimit]     where       require :: Val -> String -> Maybe a -> Parser a-      require _ _ (Just a) = return a+      require _ _ (Just a) = pure a       require val err Nothing = parseFail val err  parseGroup :: Val -> Parser Group parseGroup v = do     groupName <- parseField "name" v >>= parseString-    groupEnabled <- parseFieldOpt "enabled" v >>= maybe (return True) parseBool-    groupImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImport)-    groupGhcImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImportGHC)-    groupRules <- parseFieldOpt "rules" v >>= maybe (return []) parseArray >>= concatMapM parseRule+    groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool+    groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport)+    groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule     allowFields v ["name","enabled","imports","rules"]-    return Group{..}+    pure Group{..}     where         parseImport v = do             x <- parseString v             case word1 x of-                ("package", x) -> return $ Left x-                _ -> Right <$> parseHSE parseImportDeclWithMode v-        parseImportGHC v = do-            x <- parseString v-            case word1 x of-                 ("package", x) -> return $ Left x+                 ("package", x) -> pure $ Left x                  _ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v  ruleToGroup :: [Either HintRule Classify] -> Group-ruleToGroup = Group "" True [] []+ruleToGroup = Group "" True []  parseRule :: Val -> Parser [Either HintRule Classify] parseRule v = do     (severity, v) <- parseSeverityKey v     isRule <- isJust <$> parseFieldOpt "lhs" v     if isRule then do-        hintRuleLHS <- parseField "lhs" v >>= parseHSE parseExpWithMode-        hintRuleRHS <- parseField "rhs" v >>= parseHSE parseExpWithMode-        hintRuleNotes <- parseFieldOpt "note" v >>= maybe (return []) (fmap (map asNote) . parseArrayString)-        hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString-        hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode)--        hintRuleGhcLHS <- parseField "lhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode-        hintRuleGhcRHS <- parseField "rhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode-        hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode)+        hintRuleNotes <- parseFieldOpt "note" v >>= maybe (pure []) (fmap (map asNote) . parseArrayString)+        lhs <- parseField "lhs" v >>= parseGHC parseExpGhcWithMode+        rhs <- parseField "rhs" v >>= parseGHC parseExpGhcWithMode+        hintRuleSide <- parseFieldOpt "side" v >>= maybe (pure Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode)+        hintRuleName <- parseFieldOpt "name" v >>= maybe (pure $ guessName lhs rhs) parseString          allowFields v ["lhs","rhs","note","name","side"]-        let hintRuleScope = mempty :: Scope-        let hintRuleGhcScope = extendInstances mempty :: HsExtendInstances Scope'-        return [Left HintRule{hintRuleSeverity=severity, ..}]+        let hintRuleScope = mempty+        pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}]      else do-        names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString-        within <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin)-        return [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names]+        names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString+        within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)+        pure [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names]  parseRestrict :: RestrictType -> Val -> Parser Restrict parseRestrict restrictType v = do@@ -274,42 +263,44 @@         Just def -> do             b <- parseBool def             allowFields v ["default"]-            return $ Restrict restrictType b [] [] [] [] Nothing+            pure $ 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+            restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString+            restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)+            restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString             restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString             restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString             allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]-            return Restrict{restrictDefault=True,..}+            pure Restrict{restrictDefault=True,..}  parseWithin :: Val -> Parser [(String, String)] -- (module, decl) parseWithin v = do-    x <- parseHSE parseExpWithMode v+    x <- parseGHC parseExpGhcWithMode v     case x of-        Var _ (UnQual _ name) -> return [("",fromNamed name)]-        Var _ (Qual _ (ModuleName _ mod) name) -> return [(mod, fromNamed name)]-        Con _ (UnQual _ name) -> return [(fromNamed name,""),("",fromNamed name)]-        Con _ (Qual _ (ModuleName _ mod) name) -> return [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]+        L _ (HsVar _ (L _ (GHC.Unqual x))) -> pure $ f "" (GHC.occNameString x)+        L _ (HsVar _ (L _ (GHC.Qual mod x))) -> pure $ f (moduleNameString mod) (GHC.occNameString x)         _ -> parseFail v "Bad classification rule"+    where+        f mod name@(c:_) | isUpper c = [(mod,name),(mod ++ ['.' | mod /= ""] ++ name, "")]+        f mod name = [(mod, name)]  parseSeverityKey :: Val -> Parser (Severity, Val) parseSeverityKey v = do     (s, v) <- parseObject1 v     case getSeverity s of-        Just sev -> return (sev, v)+        Just sev -> pure (sev, v)         _ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s  -guessName :: Exp_ -> Exp_ -> String+guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String guessName lhs rhs     | n:_ <- rs \\ ls = "Use " ++ n     | n:_ <- ls \\ rs = "Redundant " ++ n     | otherwise = defaultHintName     where         (ls, rs) = both f (lhs, rhs)-        f = filter (not . isUnifyVar) . map (\x -> fromNamed (x :: Name S)) . childrenS+        f :: LHsExpr GhcPs -> [String]+        f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = GHC.occNameString $ GHC.rdrNameOcc x, not $ isUnifyVar y, y /= "."]   asNote :: String -> Note@@ -330,26 +321,17 @@         packages = [x | ConfigPackage x <- configs]         groups = [x | ConfigGroup x <- configs]         settings = concat [x | ConfigSetting x <- configs]-        packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages]-        packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageGhcModules) | Package{..} <- packages]+        packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageModules) | Package{..} <- packages]         groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]          f Group{..}             | Map.lookup groupName groupMap == Just False = []-            | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope,hintRuleGhcScope=scope'}) SettingClassify) groupRules+            | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope'}) SettingClassify) groupRules             where-              scope = asScope packageMap groupImports-              scope'= asScope' packageMap' (map (fmap unextendInstances) groupGhcImports)--asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope-asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []-    where-        f (Right x) = [x]-        f (Left x) | Just pkg <- Map.lookup x packages = pkg-                   | otherwise = error $ "asScope failed to do lookup, " ++ x+              scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) -asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> HsExtendInstances Scope'-asScope' packages xs = HsExtendInstances $ scopeCreate' (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)+asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope+asScope' packages xs = scopeCreate (HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)     where         f (Right x) = [x]         f (Left x) | Just pkg <- Map.lookup x packages = pkg

@@ -0,0 +1,61 @@+module Extension(+  defaultExtensions,+  configExtensions,+  extensionImpliedEnabledBy,+  extensionImplies+  ) where++import Data.List.Extra+import qualified Data.Map as Map+import GHC.LanguageExtensions.Type+import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx++badExtensions =+  reallyBadExtensions +++  [ Arrows -- steals proc+  , UnboxedTuples, UnboxedSums -- breaks (#) lens operator+  , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+  , {- DoRec , -} RecursiveDo -- breaks rec+  , TypeApplications -- HSE fails on @ patterns+  ]++reallyBadExtensions =+  [ TransformListComp -- steals the group keyword+  , StaticPointers -- steals the static keyword+  {- , XmlSyntax , RegularPatterns -} -- steals a-b and < operators+  , AlternativeLayoutRule -- Does not play well with 'MultiWayIf'+  , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests.+  ]++-- | Extensions we turn on by default when parsing. Aim to parse as+-- many files as we can.+defaultExtensions :: [Extension]+defaultExtensions = enumerate \\ 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 = enumerate \\ reallyBadExtensions++-- | This extension implies the following extensions are+-- enabled/disabled.+extensionImplies :: Extension -> ([Extension], [Extension])+extensionImplies = \x ->Map.findWithDefault ([], []) x mp+  where mp = Map.fromList extensionImplications++-- 'x' is implied enabled by the result extensions.+extensionImpliedEnabledBy :: Extension -> [Extension]+extensionImpliedEnabledBy = \x -> Map.findWithDefault [] x mp+  where+    mp = Map.fromListWith (++) [(b, [a]) | (a, (bs, _)) <- extensionImplications, b <- bs]++-- 'x' is implied disabled by the result extensions. Not called at this time.+_extensionImpliedDisabledBy :: Extension -> [Extension]+_extensionImpliedDisabledBy = \x -> Map.findWithDefault [] x mp+  where+    mp = Map.fromListWith (++) [(b, [a]) | (a, (_, bs)) <- extensionImplications, b <- bs]++-- | (a, bs) means extension a implies all of bs. Uses GHC source at+-- DynFlags.impliedXFlags+extensionImplications :: [(Extension, ([Extension], [Extension]))]+extensionImplications = GhclibParserEx.extensionImplications

@@ -0,0 +1,105 @@+{-# LANGUAGE ViewPatterns #-}++module Fixity(+    FixityInfo, Associativity(..),+    defaultFixities,+    fromFixitySig, toFixitySig, toFixity,+    ) where++import GHC.Generics(Associativity(..))+import GHC.Hs.Binds+import GHC.Hs.Extension+import OccName+import RdrName+import SrcLoc+import BasicTypes+import Language.Haskell.GhclibParserEx.Fixity++-- Lots of things define a fixity. None define it quite right, so let's have our own type.++-- | A Fixity definition, comprising the name the fixity applies to,+--   the direction and the precedence. As an example, a source file containing:+--+-- > infixr 3 `foo`+--+--   would create @(\"foo\", RightAssociative, 3)@.+type FixityInfo = (String, Associativity, Int)++fromFixitySig :: FixitySig GhcPs -> [FixityInfo]+fromFixitySig (FixitySig _ names (Fixity _ i dir)) =+    [(occNameString $ occName $ unLoc name, f dir, i) | name <- names]+    where+        f InfixL = LeftAssociative+        f InfixR = RightAssociative+        f InfixN = NotAssociative+fromFixitySig _ = []++toFixity :: FixityInfo -> (String, Fixity)+toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)+    where+        f LeftAssociative = InfixL+        f RightAssociative = InfixR+        f NotAssociative = InfixN++fromFixity :: (String, Fixity) -> FixityInfo+fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)+  where+    assoc dir = case dir of+      InfixL -> LeftAssociative+      InfixR -> RightAssociative+      InfixN -> NotAssociative++toFixitySig :: FixityInfo -> FixitySig GhcPs+toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x++defaultFixities :: [FixityInfo]+defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities++-- List as provided at https://github.com/ndmitchell/hlint/issues/416.+lensFixities :: [(String, Fixity)]+lensFixities = concat+    [ infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","<//~","<^~","<^^~","<**~"]+    , infix_ 4 ["%%@=","<%@=","%%=","<+=","<*=","<-=","<//=","<^=","<^^=","<**="]+    , infixr_ 2 ["<<~"]+    , infixr_ 9 ["#."]+    , infixl_ 8 [".#"]+    , infixr_ 8 ["^!","^@!"]+    , infixl_ 1 ["&","<&>","??"]+    , infixl_ 8 ["^.","^@."]+    , infixr_ 9 ["<.>","<.",".>"]+    , infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"]+    , infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="]+    , infixr_ 2 ["<~"]+    , infixr_ 2 ["`zoom`","`magnify`"]+    , infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"]+    , infixl_ 8 ["^#"]+    , infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"]+    , infix_ 4 ["<#=","#=","#%=","<#%=","#%%="]+    , infixl_ 9 [":>"]+    , infixr_ 4 ["</>~","<</>~","<.>~","<<.>~"]+    , infix_ 4 ["</>=","<</>=","<.>=","<<.>="]+    , infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"]+    , infix_ 4 [".|.=",".&.=","<.|.=","<.&.="]+    ]++otherFixities :: [(String, Fixity)]+otherFixities = concat+  -- hspec+  [ infix_ 1 ["shouldBe","shouldSatisfy","shouldStartWith","shouldEndWith","shouldContain","shouldMatchList"+              ,"shouldReturn","shouldNotBe","shouldNotSatisfy","shouldNotContain","shouldNotReturn","shouldThrow"]+    -- quickcheck+  , infixr_ 0 ["==>"]+  , infix_ 4 ["==="]+    -- esqueleto+  , infix_ 4 ["==."]+    -- lattices+  , infixr_ 5 ["\\/"] -- \/+  , infixr_ 6 ["/\\"] -- /\+  ]++customFixities :: [(String, Fixity)]+customFixities =+  infixl_ 1 ["`on`"]+        -- See https://github.com/ndmitchell/hlint/issues/425+        -- otherwise GTK apps using `on` at a different fixity have+        -- spurious warnings.

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  module GHC.Util (     module GHC.Util.View@@ -5,9 +7,6 @@   , 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@@ -17,17 +16,17 @@   , module GHC.Util.Unify    , parsePragmasIntoDynFlags-  , parseFileGhcLib, parseExpGhcLib, parseImportGhcLib+  , parseFileGhcLib, parseExpGhcLib, parseImportGhcLib, parseDeclGhcLib+  , pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn+  , pattern SrcLoc, srcFilename, srcLine, srcColumn+  , showSrcSpan',   ) where  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@@ -36,13 +35,14 @@ import GHC.Util.Scope import GHC.Util.Unify -import qualified Language.Haskell.GhclibParserEx.Parse as GhclibParserEx-import Language.Haskell.GhclibParserEx.DynFlags (parsePragmasIntoDynFlags)+import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GhclibParserEx+import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags) -import HsSyn+import GHC.Hs import Lexer import SrcLoc import DynFlags+import FastString  import System.FilePath import Language.Preprocessor.Unlit@@ -53,7 +53,76 @@ parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) parseImportGhcLib = GhclibParserEx.parseImport +parseDeclGhcLib :: String -> DynFlags -> ParseResult (LHsDecl GhcPs)+parseDeclGhcLib = GhclibParserEx.parseDeclaration+ parseFileGhcLib :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) parseFileGhcLib filename str flags =   GhclibParserEx.parseFile filename flags     (if takeExtension filename /= ".lhs" then str else unlit filename str)++{-# COMPLETE SrcSpan #-}+-- | The \"Line'\" thing is because there is already e.g. 'SrcLoc.srcSpanStartLine'+pattern SrcSpan :: String -> Int -> Int -> Int -> Int -> SrcSpan+pattern SrcSpan+  { srcSpanFilename+  , srcSpanStartLine'+  , srcSpanStartColumn+  , srcSpanEndLine'+  , srcSpanEndColumn+  }+  <-+    (toOldeSpan ->+      ( srcSpanFilename+      , srcSpanStartLine'+      , srcSpanStartColumn+      , srcSpanEndLine'+      , srcSpanEndColumn+      ))++toOldeSpan :: SrcSpan -> (String, Int, Int, Int, Int)+toOldeSpan (RealSrcSpan span) =+  ( unpackFS $ srcSpanFile span+  , srcSpanStartLine span+  , srcSpanStartCol span+  , srcSpanEndLine span+  , srcSpanEndCol span+  )+-- TODO: the bad locations are all (-1) right now+-- is this fine? it should be, since noLoc from HSE previously also used (-1) as an invalid location+toOldeSpan (UnhelpfulSpan str) =+  ( unpackFS str+  , -1+  , -1+  , -1+  , -1+  )++{-# COMPLETE SrcLoc #-}+pattern SrcLoc :: String -> Int -> Int -> SrcLoc+pattern SrcLoc+  { srcFilename+  , srcLine+  , srcColumn+  }+  <-+    (toOldeLoc ->+      ( srcFilename+      , srcLine+      , srcColumn+      ))++toOldeLoc :: SrcLoc -> (String, Int, Int)+toOldeLoc (RealSrcLoc loc) =+  ( unpackFS $ srcLocFile loc+  , srcLocLine loc+  , srcLocCol loc+  )+toOldeLoc (UnhelpfulLoc str) =+  ( unpackFS str+  , -1+  , -1+  )++showSrcSpan' :: SrcSpan -> String+showSrcSpan' = unsafePrettyPrint

@@ -96,8 +96,8 @@ -- 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 ++ " #-}")+  L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")  mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment mkLangExts loc exts =-  LL loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")+  L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")

@@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-}+ module GHC.Util.Brackets (Brackets'(..), isApp,isOpApp,isAnyApp) where -import HsSyn+import GHC.Hs import SrcLoc import BasicTypes import Language.Haskell.GhclibParserEx.GHC.Hs.Expr@@ -22,14 +24,14 @@   -- 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' (L _ (HsPar _ (L _ SectionL{}))) = Nothing+  remParen' (L _ (HsPar _ (L _ SectionR{}))) = Nothing+  remParen' (L _ (HsPar _ x)) = Just x   remParen' _ = Nothing -  addParen' e = noLoc $ HsPar noExt e+  addParen' e = noLoc $ HsPar noExtField e -  isAtom' (LL _ x) = case x of+  isAtom' (L _ x) = case x of       HsVar{} -> True       HsUnboundVar{} -> True       HsRecFld{} -> True@@ -60,33 +62,36 @@         isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i         isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f         isNegativeOverLit _ = False-  isAtom' _ = False -- '{-# COMPLETE LL #-}'+  isAtom' _ = False -- '{-# COMPLETE L #-}'    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+     | isSection parent, L _ HsApp{} <- child = False+     | L _ OpApp{} <- parent, L _ HsApp{} <- child = False+     | L _ ExplicitList{} <- parent = False+     | L _ ExplicitTuple{} <- parent = False+     | L _ HsIf{} <- parent, isAnyApp child = False+     | L _ HsApp{} <- parent, i == 0, L _ HsApp{} <- child = False+     | L _ ExprWithTySig{} <- parent, i == 0, isApp child = False+     | L _ RecordCon{} <- parent = False+     | L _ RecordUpd{} <- parent, i /= 0 = False++     -- These all have view patterns embedded within them, or are naturally followed by ->, so we have to watch out for+     -- @(x::y) -> z@ which is valid, as either a type annotation, or a view pattern.+     | L _ HsLet{} <- parent, isApp child = False+     | L _ HsDo{} <- parent, isAnyApp child = False+     | L _ HsLam{} <- parent, isAnyApp child = False+     | L _ HsCase{} <- parent, isAnyApp child = False++     | L _ HsPar{} <- parent = False      | otherwise = True -instance Brackets' (Pat GhcPs) where-  remParen' (LL _ (ParPat _ x)) = Just x+instance Brackets' (Located (Pat GhcPs)) where+  remParen' (L _ (ParPat _ x)) = Just x   remParen' _ = Nothing-  addParen' e = noLoc $ ParPat noExt e+  addParen' e = noLoc $ ParPat noExtField e -  isAtom' (LL _ x) = case x of+  isAtom' (L _ x) = case x of     ParPat{} -> True     TuplePat{} -> True     ListPat{} -> True@@ -108,20 +113,20 @@       isSignedLit HsFloatPrim{} = True       isSignedLit HsDoublePrim{} = True       isSignedLit _ = False-  isAtom' _ = False -- '{-# COMPLETE LL #-}'+  isAtom' _ = False -- '{-# COMPLETE L #-}'    needBracket' _ parent child     | isAtom' child = False-    | LL _ TuplePat{} <- parent = False-    | LL _ ListPat{} <- parent = False+    | L _ TuplePat{} <- parent = False+    | L _ ListPat{} <- parent = False     | otherwise = True  instance Brackets' (LHsType GhcPs) where-  remParen' (LL _ (HsParTy _ x)) = Just x+  remParen' (L _ (HsParTy _ x)) = Just x   remParen' _ = Nothing-  addParen' e = noLoc $ HsParTy noExt e+  addParen' e = noLoc $ HsParTy noExtField e -  isAtom' (LL _ x) = case x of+  isAtom' (L _ x) = case x of       HsParTy{} -> True       HsTupleTy{} -> True       HsListTy{} -> True@@ -132,18 +137,18 @@       HsSpliceTy{} -> True       HsWildCardTy{} -> True       _ -> False-  isAtom' _ = False -- '{-# COMPLETE LL #-}'+  isAtom' _ = False -- '{-# COMPLETE L #-}'    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+    | L _ HsFunTy{} <- parent, L _ HsAppTy{} <- child = False+    | L _ HsTupleTy{} <- parent = False+    | L _ HsListTy{} <- parent = False+    | L _ HsExplicitTupleTy{} <- parent = False+    | L _ HsListTy{} <- parent = False+    | L _ HsExplicitListTy{} <- parent = False+    | L _ HsOpTy{} <- parent, L _ HsAppTy{} <- child = False+    | L _ HsParTy{} <- parent = False     | otherwise = True

@@ -1,4 +1,4 @@-module GHC.Util.DynFlags (baseDynFlags) where+module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where  import DynFlags import GHC.LanguageExtensions.Type@@ -17,3 +17,7 @@   --    hlint.yaml:860   let enable = [TemplateHaskellQuotes]   in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable+++initGlobalDynFlags :: IO ()+initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags

@@ -1,19 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  module GHC.Util.FreeVars (-    vars', varss', pvars', freeVarSet'-  , Vars' (..), FreeVars'(..) , AllVars' (..)+    vars', varss', pvars',+    Vars' (..), FreeVars'(..) , AllVars' (..)   ) where  import RdrName-import HsTypes+import GHC.Hs.Types import OccName import Name-import HsSyn+import GHC.Hs import SrcLoc import Bag (bagToList) @@ -21,6 +19,7 @@ import Data.Generics.Uniplate.Operations import Data.Monoid import Data.Semigroup+import Data.List.Extra import Data.Set (Set) import qualified Data.Set as Set import Prelude@@ -69,7 +68,7 @@ -- ================================== -- 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 (AllVars' a) => AllVars' [a] where  allVars' = mconcatMap allVars' instance (FreeVars' a) => FreeVars' [a] where  freeVars' = Set.unions . map freeVars'  -- Construct a `Vars` value with no bound vars.@@ -94,79 +93,83 @@  -- 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' (L _ (Unqual x)) = [x]+unqualNames' (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)) = free' (allVars' mg) -- Lambda abstraction. Currently always a single match.-  freeVars' (dL -> L _ (HsLamCase _ mg)) = free' (allVars' mg) -- 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' (L _ (HsVar _ x)) = Set.fromList $ unqualNames' x -- Variable.+  freeVars' (L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes".+  freeVars' (L _ (HsLam _ mg)) = free' (allVars' mg) -- Lambda abstraction. Currently always a single match.+  freeVars' (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free' (allVars' ms) -- Lambda case+  freeVars' (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars' of_ ^+ free' (allVars' ms) -- Case expr.+  freeVars' (L _ (HsLet _ binds e)) = inFree' binds e -- Let (rec).+  freeVars' (L _ (HsDo _ ctxt (L _ stmts))) = free' (allVars' stmts) -- Do block.+  freeVars' (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars' flds -- Record construction.+  freeVars' (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars' e : map freeVars' flds -- Record update.+  freeVars' (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' (L _ HsConLikeOut{}) = mempty -- After typechecker.+  freeVars' (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.+  freeVars' (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope 'fromLabel'.+  freeVars' (L _ HsIPVar{}) = mempty -- Implicit parameter.+  freeVars' (L _ HsOverLit{}) = mempty -- Overloaded literal.+  freeVars' (L _ HsLit{}) = mempty -- Simple literal.+  freeVars' (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.+  freeVars' (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.+  freeVars' (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@(L _ HsAppType{})) = freeVars' $ children e -- Visible type application e.g. 'f @ Int x y'.+  -- freeVars' (e@(L _ HsApp{})) = freeVars' $ children e -- Application.+  -- freeVars' (e@(L _ OpApp{})) = freeVars' $ children e -- Operator application.+  -- freeVars' (e@(L _ NegApp{})) = freeVars' $ children e -- Negation operator.+  -- freeVars' (e@(L _ HsPar{})) = freeVars' $ children e -- Parenthesized expr.+  -- freeVars' (e@(L _ SectionL{})) = freeVars' $ children e -- Left section.+  -- freeVars' (e@(L _ SectionR{})) = freeVars' $ children e -- Right section.+  -- freeVars' (e@(L _ ExplicitTuple{})) = freeVars' $ children e -- Explicit tuple and sections thereof.+  -- freeVars' (e@(L _ ExplicitSum{})) = freeVars' $ children e -- Used for unboxed sum types.+  -- freeVars' (e@(L _ HsIf{})) = freeVars' $ children e -- If.+  -- freeVars' (e@(L _ ExplicitList{})) = freeVars' $ children e -- Syntactic list e.g. '[a, b, c]'.+  -- freeVars' (e@(L _ ExprWithTySig{})) = freeVars' $ children e -- Expr with type signature.+  -- freeVars' (e@(L _ ArithSeq {})) = freeVars' $ children e -- Arithmetic sequence.+  -- freeVars' (e@(L _ HsSCC{})) = freeVars' $ children e -- Set cost center pragma (expr whose const is to be measured).+  -- freeVars' (e@(L _ HsCoreAnn{})) = freeVars' $ children e -- Pragma.+  -- freeVars' (e@(L _ HsBracket{})) = freeVars' $ children e -- Haskell bracket.+  -- freeVars' (e@(L _ HsSpliceE{})) = freeVars' $ children e -- Template haskell splice expr.+  -- freeVars' (e@(L _ HsProc{})) = freeVars' $ children e -- Proc notation for arrows.+  -- freeVars' (e@(L _ HsStatic{})) = freeVars' $ children e -- Static pointers extension.+  -- freeVars' (e@(L _ HsArrApp{})) = freeVars' $ children e -- Arrow tail or arrow application.+  -- freeVars' (e@(L _ HsArrForm{})) = freeVars' $ children e -- Come back to it. Arrow tail or arrow application.+  -- freeVars' (e@(L _ HsTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars' (e@(L _ HsBinTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars' (e@(L _ HsTickPragma{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars' (e@(L _ EAsPat{})) = freeVars' $ children e -- Expr as pat.+  -- freeVars' (e@(L _ EViewPat{})) = freeVars' $ children e -- View pattern.+  -- freeVars' (e@(L _ ELazyPat{})) = freeVars' $ children e -- Lazy pattern.    freeVars' e = freeVars' $ children e +instance FreeVars' (LHsTupArg GhcPs) where+  freeVars' (L _ (Present _ args)) = freeVars' args+  freeVars' _ = mempty+ instance FreeVars' (LHsRecField GhcPs (LHsExpr GhcPs)) where-   freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x+   freeVars' (L _ (HsRecField _ x _)) = freeVars' x  instance FreeVars' (LHsRecUpdField GhcPs) where-  freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x+  freeVars' (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.+instance AllVars' (Located (Pat GhcPs)) where+  allVars' (L _ (VarPat _ (L _ x))) = Vars' (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.+  allVars' (L _ (AsPat _  n x)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars' x -- As pattern.+  allVars' (L _ (ConPatIn _ (RecCon (HsRecFields flds _)))) = allVars' flds+  allVars' (L _ (NPlusKPat _ n _ _ _ _)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.+  allVars' (L _ (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' (L _ WildPat{}) = mempty -- Wildcard pattern.+  allVars' (L _ ConPatOut{}) = mempty -- Renamer/typechecker.+  allVars' (L _ LitPat{}) = mempty -- Literal pattern.+  allVars' (L _ 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.@@ -180,76 +183,76 @@    allVars' p = allVars' $ children p -instance AllVars' (LHsRecField GhcPs (LPat GhcPs)) where-   allVars' (dL -> L _ (HsRecField _ x _)) = allVars' x+instance AllVars' (LHsRecField GhcPs (Located (Pat GhcPs))) where+   allVars' (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' (L _ (LastStmt _ expr _ _)) = freeVars_' expr -- The last stmt of a 'ListComp', 'MonadComp', 'DoExpr','MDoExpr'.+  allVars' (L _ (BindStmt _ pat expr _ _)) = allVars' pat <> freeVars_' expr -- A generator e.g. 'x <- [1, 2, 3]'.+  allVars' (L _ (BodyStmt _ expr _ _)) = freeVars_' expr -- A boolean guard e.g. 'even x'.+  allVars' (L _ (LetStmt _ binds)) = allVars' binds -- A local declaration e.g. 'let y = x + 1'+  allVars' (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' (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' (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.+  allVars' (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' (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars' (bagToList binds) -- Value bindings.+  allVars' (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' (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' (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' (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars' (noLoc $ VarPat noExtField n :: LPat 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' (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' (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.+  allVars' (L _ VarBind{}) = mempty -- Typechecker.+  allVars' (L _ AbsBinds{}) = mempty -- Not sure but I think renamer.    allVars' _ = mempty -- New ctor.  instance AllVars' (MatchGroup GhcPs (LHsExpr GhcPs)) where-  allVars' (MG _ _alts@(dL -> L _ alts) _) = inVars' (foldMap (allVars' . m_pats) ms) (allVars' (map m_grhss ms))+  allVars' (MG _ _alts@(L _ alts) _) = inVars' (foldMap (allVars' . m_pats) ms) (allVars' (map m_grhss ms))     where ms = map unLoc alts   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)) = inVars' (allVars' pats) (allVars' grhss) -- Everything else.+  allVars' (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars' (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars' pats <> allVars' grhss -- A pattern matching on an argument of a function binding.+  allVars' (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars' ctxt <> allVars' pats <> allVars' grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.+  allVars' (L _ (Match _ _ pats grhss)) = inVars' (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' (PatGuard FunRhs{mc_fun=n}) = allVars' (noLoc $ VarPat noExtField n :: LPat 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' (GRHSs _ grhss binds) = inVars' binds (mconcatMap allVars' grhss)    allVars' _ = mempty -- New ctor.  instance AllVars' (LGRHS GhcPs (LHsExpr GhcPs)) where-  allVars' (dL -> L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards+  allVars' (L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards    allVars' _ = mempty -- New ctor.  instance AllVars' (LHsDecl GhcPs) where-  allVars' (dL -> L l (ValD _ bind)) = allVars' (cL l bind :: LHsBind GhcPs)+  allVars' (L l (ValD _ bind)) = allVars' (L l bind :: LHsBind GhcPs)    allVars' _ = mempty  -- We only consider value bindings. @@ -263,6 +266,3 @@  pvars' :: AllVars' a => a -> [String] pvars' = Set.toList . Set.map occNameString . bound' . allVars'--freeVarSet' :: FreeVars' a => a -> Set String-freeVarSet' = Set.map occNameString . freeVars'

@@ -1,20 +1,12 @@ {-# LANGUAGE NamedFieldPuns #-} -module GHC.Util.HsDecl (declName,bindName,isForD',isNewType',isDerivD',isClsDefSig')+module GHC.Util.HsDecl (declName,bindName) where -import HsSyn+import GHC.Hs import OccName import SrcLoc -isNewType' :: NewOrData -> Bool-isNewType' NewType = True-isNewType' DataType = False--isForD', isDerivD' :: LHsDecl GhcPs -> Bool-isForD' (LL _ ForD{}) = True; isForD' _ = False-isDerivD' (LL _ DerivD{}) = True; isDerivD' _ = 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),@@ -22,7 +14,7 @@ -- want to tell users to rename binders that they aren't creating -- right now and therefore usually cannot change. declName :: LHsDecl GhcPs -> Maybe String-declName (LL _ x) = occNameString . occName <$> case x of+declName (L _ 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@@ -36,13 +28,9 @@     ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name     ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name     _ -> Nothing-declName _ = Nothing {- COMPLETE LL-}   bindName :: LHsBind GhcPs -> Maybe String-bindName (LL _ FunBind{fun_id}) = Just $ occNameString $ occName $ unLoc fun_id-bindName (LL _ VarBind{var_id}) = Just $ occNameString $ occName var_id+bindName (L _ FunBind{fun_id}) = Just $ occNameString $ occName $ unLoc fun_id+bindName (L _ VarBind{var_id}) = Just $ occNameString $ occName var_id bindName _ = Nothing--isClsDefSig' :: Sig GhcPs -> Bool-isClsDefSig' (ClassOpSig _ True _ _) = True; isClsDefSig' _ = False

@@ -2,21 +2,18 @@ {-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TupleSections #-} ---  Keep until 'descendApps', 'transformApps' and 'allowLeftSection'--- are used.-{-# OPTIONS_GHC -Wno-unused-top-binds #-}- module GHC.Util.HsExpr (-    dotApp', dotApps'-  , simplifyExp', niceLambda', niceDotApp'+    dotApps', lambda+  , simplifyExp', niceLambda', niceLambdaR'   , Brackets'(..)   , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp'   , paren'   , replaceBranches'-  , needBracketOld', transformBracketOld', descendBracketOld', reduce', reduce1', fromParen1'+  , needBracketOld', transformBracketOld', fromParen1'+  , allowLeftSection, allowRightSection ) where -import HsSyn+import GHC.Hs import BasicTypes import SrcLoc import FastString@@ -27,7 +24,7 @@ import GHC.Util.Brackets import GHC.Util.View import GHC.Util.FreeVars-import GHC.Util.Pat+import GHC.Util.Outputable (unsafePrettyPrint)  import Control.Applicative import Control.Monad.Trans.State@@ -37,21 +34,27 @@ import Data.List.Extra import Data.Tuple.Extra -import Refact.Types hiding (Match)+import Refact (toSS')+import Refact.Types hiding (SrcSpan, Match) import qualified Refact.Types as R (SrcSpan) +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances  -- | '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+dotApp' x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (noLoc $ mkVarUnqual (fsLit "."))) y  dotApps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs dotApps' [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list" dotApps' [x] = x dotApps' (x : xs) = dotApp' x (dotApps' xs) +-- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@+lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs+lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated)+ -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren' :: LHsExpr GhcPs -> LHsExpr GhcPs paren' x@@ -60,34 +63,27 @@  universeParentExp' :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)] universeParentExp' xs = concat [(Nothing, x) : f x | x <- childrenBi xs]-    where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p]+    where f p = concat [(Just (i,p), c) : f c | (i,c) <- zipFrom 0 $ children p]   apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs-apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y)+apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y)  fromApps' :: LHsExpr GhcPs  -> [LHsExpr GhcPs]-fromApps' (LL _ (HsApp _ x y)) = fromApps' x ++ [y]+fromApps' (L _ (HsApp _ x y)) = fromApps' x ++ [y] fromApps' x = [x]  childrenApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]-childrenApps' (LL _ (HsApp _ x y)) = childrenApps' x ++ [y]+childrenApps' (L _ (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 (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp noExtField 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 @@ -95,7 +91,7 @@ descendIndex' f x = flip evalState 0 $ flip descendM x $ \y -> do     i <- get     modify (+1)-    return $ f i y+    pure $ f i y  --  There are differences in pretty-printing between GHC and HSE. This --  version never removes brackets.@@ -104,7 +100,7 @@     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 i y@(L _ e) | needBracket' i x y = addParen' y         f _ y = y  -- Add brackets as suggested 'needBracket' at 1-level of depth.@@ -114,16 +110,16 @@ -- 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)+  where mkApp x y = rebracket1' (noLoc $ HsApp noExtField x y)   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)) =+simplifyExp' (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y)))+simplifyExp' e@(L _ (HsLet _ (L _ (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 _))))]) _) _ _)]+    [L _ (FunBind _ _(MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (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 ->@@ -135,7 +131,7 @@  -- Rewrite '($) . b' as 'b'. niceDotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-niceDotApp' (LL _ (HsVar _ (L _ r))) b | occNameString (rdrNameOcc r) == "$" = b+niceDotApp' (L _ (HsVar _ (L _ r))) b | occNameString (rdrNameOcc r) == "$" = b niceDotApp' a b = dotApp' a b  @@ -143,7 +139,9 @@ niceLambda' :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs niceLambda' ss e = fst (niceLambdaR' ss e)-- We don't support refactorings yet. +allowRightSection :: String -> Bool allowRightSection x = x `notElem` ["-","#"]+allowLeftSection :: String -> Bool allowLeftSection x = x /= "#"  -- Implementation. Try to produce special forms (e.g. sections,@@ -152,59 +150,110 @@              -> 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+-- Rewrite @\ -> e@ as @e@+-- These are encountered as recursive calls.+niceLambdaR' xs (SimpleLambda [] x) = niceLambdaR' xs x++-- Rewrite @\xs -> (e)@ as @\xs -> e@.+niceLambdaR' xs (L _ (HsPar _ x)) = niceLambdaR' xs x++-- @\vs v -> ($) e v@ ==> @\vs -> e@+-- @\vs v -> e $ v@ ==> @\vs -> e@+niceLambdaR' (unsnoc -> Just (vs, v)) (view' -> App2' f e (view' -> Var_' v'))+  | isDol f+  , v == v'+  , vars' e `disjoint` [v]+  = niceLambdaR' vs e++-- @\v -> thing + v@ ==> @\v -> (thing +)@  (heuristic: @v@ must be a single+-- lexeme, or it all gets too complex)+niceLambdaR' [v] (L _ (OpApp _ e f (view' -> Var_' v')))+  | isLexeme e+  , v == v'+  , vars' e `disjoint` [v]+  , L _ (HsVar _ (L _ fname)) <- f+  , isSymOcc $ rdrNameOcc fname+  = (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)])++-- @\vs v -> f x v@ ==> @\vs -> f x@+niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (HsApp _ (L _ (HsApp _ f e)) (view' -> Var_' v')))+  | v == v'+  , vars' e `disjoint` [v]+  = niceLambdaR' vs $ apps' [f, e]++-- @\vs v -> (v `f`)@ ==> @\vs -> f@+niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view' -> Var_' v') f))+  | v == v' = niceLambdaR' vs f++-- Strip one variable pattern from the end of a lambdas match, and place it in our list of factoring variables.+niceLambdaR' xs (SimpleLambda ((view' -> PVar_' v):vs) x)+  | v `notElem` xs = niceLambdaR' (xs++[v]) $ lambda vs 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)+niceLambdaR' [x] (view' -> App2' op@(L _ (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'.+      let e = rebracket1' $ addParen' (noLoc $ SectionR noExtField op r)+      in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)])+-- 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 [])+  | Just (z, subts) <- factor y, x `notElem` vars' z = (z, \s -> [mkRefact subts s])   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+    factor y@(L _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini])+    factor y@(L _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst       = let r = niceDotApp' ini z         in if astEq r z then Just (r, ss) else Just (r, ini : ss)-    factor (LL _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op+    factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op       = let r = niceDotApp' y z         in if astEq r z then Just (r, ss) else Just (r, y : ss)-    factor (LL _ (HsPar _ y@(LL _ HsApp{}))) = factor y+    factor (L _ (HsPar _ y@(L _ 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'.+    mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan+    mkRefact subts s =+      let tempSubts = zipWith (\a b -> ([a], toSS' b)) ['a' .. 'z'] subts+          template = dotApps' (map (strToVar . fst) tempSubts)+      in Replace Expr s tempSubts (unsafePrettyPrint template)+-- Rewrite @\x y -> x + y@ as @(+)@.+niceLambdaR' [x,y] (L _ (OpApp _ (view' -> Var_' x1) op@(L _ HsVar {}) (view' -> Var_' y1)))+    | x == x1, y == y1, vars' op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)])+-- 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 [])+  | x == x1, y == y1, vars' op `disjoint` [x, y] =+      ( gen op+      , \s -> [Replace Expr s [("x", toSS' op)] (unsafePrettyPrint $ gen (strToVar "x"))]+      )+  where+    gen = noLoc . HsApp noExtField (strToVar "flip")++-- We're done factoring, but have no variables left, so we shouldn't make a lambda.+-- @\ -> e@ ==> @e@+niceLambdaR' [] e = (e, 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 [])+  let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)+      grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField}+      match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)+      matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]}+  in (noLoc $ HsLam noExtField matchGroup, const [])   -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches' :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)-replaceBranches' (LL l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExt Nothing a b c))+replaceBranches' (L l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExtField Nothing a b c)) -replaceBranches' (LL s (HsCase _ a (MG _ (L l bs) FromSource))) =-  (concatMap f bs, \xs -> cL s (HsCase noExt a (MG noExt (cL l (g bs xs)) Generated)))+replaceBranches' (L s (HsCase _ a (MG _ (L l bs) FromSource))) =+  (concatMap f bs, \xs -> cL s (HsCase noExtField a (MG noExtField (cL l (g bs xs)) Generated)))   where     f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]-    f (LL _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (LL _ (GRHS _ _ x)) <- xs]-    f _ = undefined -- {-# COMPLETE LL #-}+    f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]+    f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch"      g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]-    g (LL s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =-      cL s1 (Match noExt CaseAlt a (GRHSs noExt [cL a (GRHS noExt gs x) | (LL a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs+    g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =+      cL s1 (Match noExtField CaseAlt a (GRHSs noExtField [cL a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs       where  (as, bs) = splitAt (length ns) xs     g [] [] = []     g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"@@ -240,32 +289,13 @@     g1 = (fst .) . g     g2 = (snd .) . g -    f i (LL _ (HsPar _ y)) z | not $ needBracketOld' i x y = (y, z)-    f i y z                  | needBracketOld' i x y = (addParen' y, addParen' z)-    f _ y z                  = (y, z)+    f i (L _ (HsPar _ y)) z | not $ needBracketOld' i x y = (y, z)+    f i y z                 | needBracketOld' i x y = (addParen' y, addParen' z)+    f _ y z                 = (y, z)      f1 = ((fst .) .) . f     f2 = ((snd .) .) . f -reduce' :: LHsExpr GhcPs -> LHsExpr GhcPs-reduce' = fromParen' . transform reduce1'--reduce1' :: LHsExpr GhcPs -> LHsExpr GhcPs-reduce1' (LL loc (HsApp _ len (LL _ (HsLit _ (HsString _ xs)))))-  | varToStr len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))-  where n = fromIntegral $ length (unpackFS xs)-reduce1' (LL loc (HsApp _ len (LL _ (ExplicitList _ _ xs))))-  | varToStr len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))-  where n = fromIntegral $ length xs-reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr op == "==" = strToVar (show (astEq x y))-reduce1' (view' -> App2' op (LL _ (HsLit _ (HsInt _ x))) (LL _ (HsLit _ (HsInt _ y)))) | varToStr op == ">=" = strToVar $ show (x >= y)-reduce1' (view' -> App2' op x y)-    | varToStr op == "&&" && varToStr x == "True"  = y-    | varToStr op == "&&" && varToStr x == "False" = x-reduce1' (LL _ (HsPar _ x)) | isAtom' x = x-reduce1' x = x-- fromParen1' :: LHsExpr GhcPs -> LHsExpr GhcPs-fromParen1' (LL _ (HsPar _ x)) = x+fromParen1' (L _ (HsPar _ x)) = x fromParen1' x = x

@@ -1,23 +0,0 @@--module GHC.Util.HsType (-    Brackets'(..)-  , fromTyParen'-  , isTyQuasiQuote'-  , isUnboxedTuple'-  ) where--import HsSyn-import SrcLoc--import GHC.Util.Brackets--fromTyParen' :: LHsType GhcPs -> LHsType GhcPs-fromTyParen' (LL _ (HsParTy _ x)) = x-fromTyParen' x = x--isTyQuasiQuote' :: LHsType GhcPs -> Bool-isTyQuasiQuote' (LL _ (HsSpliceTy _ HsQuasiQuote{})) = True; isTyQuasiQuote' _ = False--isUnboxedTuple' :: HsTupleSort -> Bool-isUnboxedTuple' HsUnboxedTuple = True-isUnboxedTuple' _ = False

@@ -1,13 +0,0 @@--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]]

@@ -1,15 +1,13 @@  module GHC.Util.Module (modName, fromModuleName') where -import HsSyn+import GHC.Hs 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 #-}+modName (L _ HsModule {hsmodName=Nothing}) = "Main"+modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n  fromModuleName' :: Located ModuleName -> String-fromModuleName' (LL _ n) = moduleNameString n-fromModuleName' _ = "" -- {# COMPLETE LL #}+fromModuleName' (L _ n) = moduleNameString n

@@ -1,58 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}--module GHC.Util.Pat (-    strToPat', patToStr'-  , Brackets'(..)-  , fromPChar', isPFieldWildcard', hasPFieldsDotDot', isPWildCard'-  , isPFieldPun', isPatTypeSig', isPBangPat', isPViewPat'-  ) 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 #-}--isPWildCard' :: Pat GhcPs -> Bool-isPWildCard' (LL _ (WildPat _)) = True-isPWildCard' _ = False--isPFieldPun' :: LHsRecField GhcPs (Pat GhcPs) -> Bool-isPFieldPun' (LL _ HsRecField {hsRecPun=True}) = True-isPFieldPun' _ = False--isPatTypeSig', isPBangPat', isPViewPat' :: Pat GhcPs -> Bool-isPatTypeSig' (LL _ SigPat{}) = True; isPatTypeSig' _ = False-isPBangPat' (LL _ BangPat{}) = True; isPBangPat' _ = False-isPViewPat' (LL _ ViewPat{}) = True; isPViewPat' _ = False

@@ -2,11 +2,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module GHC.Util.Scope (-   Scope'-  ,scopeCreate',scopeImports',scopeMatch',scopeMove'+   Scope+  ,scopeCreate,scopeMatch,scopeMove ) where -import HsSyn+import GHC.Hs import SrcLoc import BasicTypes import Module@@ -16,24 +16,25 @@  import GHC.Util.Module import GHC.Util.RdrName-import Outputable+import GHC.Util.Outputable -import Data.List import Data.List.Extra import Data.Maybe  -- A scope is a list of import declarations.-newtype Scope' = Scope' [LImportDecl GhcPs]-               deriving (Outputable, Monoid, Semigroup)+newtype Scope = Scope [LImportDecl GhcPs]+               deriving (Monoid, Semigroup) --- Create a 'Scope' from a module's import declarations.-scopeCreate' :: HsModule GhcPs -> Scope'-scopeCreate' xs = Scope' $ [prelude | not $ any isPrelude res] ++ res+instance Show Scope where+    show (Scope x) = unsafePrettyPrint x++-- Create a 'Scope from a module's import declarations.+scopeCreate :: HsModule GhcPs -> Scope+scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res   where     -- Package qualifier of an import declaration.     pkg :: LImportDecl GhcPs -> Maybe StringLiteral-    pkg (LL _ x) = ideclPkgQual x-    pkg _  = Nothing -- {-# COMPLETE LL #-}+    pkg (L _ x) = ideclPkgQual x      -- The import declaraions contained by the module 'xs'.     res :: [LImportDecl GhcPs]@@ -45,48 +46,43 @@      -- Predicate to test for a 'Prelude' import declaration.     isPrelude :: LImportDecl GhcPs -> Bool-    isPrelude (LL _ x) = fromModuleName' (ideclName x) == "Prelude"-    isPrelude _ = False -- {-# COMPLETE LL #-}---- Access the imports in scope 'x'.-scopeImports' :: Scope' -> [LImportDecl GhcPs]-scopeImports' (Scope' x) = x+    isPrelude (L _ x) = fromModuleName' (ideclName x) == "Prelude"  -- Test if two names in two scopes may be referring to the same -- thing. This is the case if the names are equal and (1) denote a -- builtin type or data constructor or (2) the intersection of the -- candidate modules where the two names arise is non-empty.-scopeMatch' :: (Scope', Located RdrName) -> (Scope', Located RdrName) -> Bool-scopeMatch' (a, x) (b, y)+scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool+scopeMatch (a, x) (b, y)   | isSpecial' x && isSpecial' y = rdrNameStr' x == rdrNameStr' y   | isSpecial' x || isSpecial' y = False   | otherwise =-     rdrNameStr' (unqual' x) == rdrNameStr' (unqual' y) && not (null $ possModules' a x `intersect` possModules' b y)+     rdrNameStr' (unqual' x) == rdrNameStr' (unqual' y) && not (possModules a x `disjoint` possModules b y)  -- Given a name in a scope, and a new scope, create a name for the new -- scope that will refer to the same thing. If the resulting name is -- ambiguous, pick a plausible candidate.-scopeMove' :: (Scope', Located RdrName) -> Scope' -> Located RdrName-scopeMove' (a, x@(fromQual' -> Just name)) (Scope' b) = case imps of-  [] -> head $ real ++ [x]-  imp:_ | all ideclQualified imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name+scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName+scopeMove (a, x@(fromQual' -> Just name)) (Scope b) = case imps of+  [] -> headDef x real+  imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name         | otherwise -> unqual' x   where     real :: [Located RdrName]-    real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules' a x]+    real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules a x]      imps :: [ImportDecl GhcPs]-    imps = [unLoc i | r <- real, i <- b, possImport' i r]-scopeMove' (_, x) _ = x+    imps = [unLoc i | r <- real, i <- b, possImport i r]+scopeMove (_, x) _ = x  -- Calculate which modules a name could possibly lie in. If 'x' is -- qualified but no imported element matches it, assume the user just -- lacks an import.-possModules' :: Scope' -> Located RdrName -> [String]-possModules' (Scope' is) x = f x+possModules :: Scope -> Located RdrName -> [String]+possModules (Scope is) x = f x   where     res :: [String]-    res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport' i x]+    res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport i x]      f :: Located RdrName -> [String]     f n | isSpecial' n = [""]@@ -95,12 +91,12 @@  -- Determine if 'x' could possibly lie in the module named by the -- import declaration 'i'.-possImport' :: LImportDecl GhcPs -> Located RdrName -> Bool-possImport' i n | isSpecial' n = False-possImport' (LL _ i) (L _ (Qual mod x)) =-  moduleNameString mod `elem` map fromModuleName' ms && possImport' (noLoc i{ideclQualified=False}) (noLoc $ mkRdrUnqual x)+possImport :: LImportDecl GhcPs -> Located RdrName -> Bool+possImport i n | isSpecial' n = False+possImport (L _ i) (L _ (Qual mod x)) =+  moduleNameString mod `elem` map fromModuleName' ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)   where ms = ideclName i : maybeToList (ideclAs i)-possImport' (LL _ i) (L _ (Unqual x)) = not (ideclQualified i) && maybe True f (ideclHiding i)+possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)   where     f :: (Bool, Located [LIE GhcPs]) -> Bool     f (hide, L _ xs) =@@ -122,4 +118,4 @@      unwrapName :: LIEWrappedName RdrName -> String     unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))-possImport' _ _ = False -- {-# COMPLETE LL #-}+possImport _ _ = False

@@ -1,30 +1,30 @@-{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}  module GHC.Util.Unify(     Subst', fromSubst',-    validSubst', substitute',-    unifyExp'+    validSubst', removeParens, substitute',+    unifyExp     ) where +import Control.Applicative import Control.Monad import Data.Generics.Uniplate.Operations import Data.Char-import Data.List.Extra import Data.Data-import Data.Tuple.Extra+import Data.List.Extra import Util -import HsSyn+import GHC.Hs import SrcLoc as GHC import Outputable hiding ((<>)) import RdrName import OccName +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util.Outputable import GHC.Util.HsExpr-import GHC.Util.Pat import GHC.Util.RdrName import GHC.Util.View @@ -39,15 +39,12 @@ -- A list of substitutions. A key may be duplicated, you need to call --  'check' to ensure the substitution is valid. newtype Subst' a = Subst' [(String, a)]-    deriving (Semigroup, Monoid)+    deriving (Semigroup, Monoid, Functor)  -- Unpack the substitution. fromSubst' :: Subst' a -> [(String, a)] fromSubst' (Subst' xs) = xs -instance Functor Subst' where-    fmap f (Subst' xs) = Subst' $ map (second f) xs -- Interesting.- instance Outputable a => Show (Subst' a) where     show (Subst' xs) = unlines [a ++ " = " ++ unsafePrettyPrint b | (a,b) <- xs] @@ -57,6 +54,12 @@     where f (x, y : ys) | all (eq y) ys = Just (x, y)           f _ = Nothing +-- Remove unnecessary brackets from a Subst'. The first argument is a list of unification variables+-- for which brackets should be removed from their substitutions.+removeParens :: [String] -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)+removeParens noParens (Subst' xs) = Subst' $+  map (\(x, y) -> if x `elem` noParens then (x, fromParen' y) else (x, y)) xs+ -- Peform a substition. -- Returns (suggested replacement, refactor template), both with brackets added -- as needed.@@ -66,28 +69,28 @@   where     exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)     -- Variables.-    exp (LL _ (HsVar _ x)) = lookup (rdrNameStr' x) bind+    exp (L _ (HsVar _ x)) = lookup (rdrNameStr' x) bind     -- Operator applications.-    exp (LL loc (OpApp _ lhs (LL _ (HsVar _ x)) rhs))-      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (OpApp noExt lhs y rhs))+    exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (OpApp noExtField lhs y rhs))     -- Left sections.-    exp (LL loc (SectionL _ exp (LL _ (HsVar _ x))))-      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionL noExt exp y))+    exp (L loc (SectionL _ exp (L _ (HsVar _ x))))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionL noExtField exp y))     -- Right sections.-    exp (LL loc (SectionR _ (LL _ (HsVar _ x)) exp))-      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionR noExt y exp))+    exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionR noExtField y exp))     exp _ = Nothing      pat :: LPat GhcPs -> LPat GhcPs     -- Pattern variables.-    pat (LL _ (VarPat _ x))-      | Just y@(LL _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat' (varToStr y)+    pat (L _ (VarPat _ x))+      | Just y@(L _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat $ varToStr y     pat x = x :: LPat GhcPs      typ :: LHsType GhcPs -> LHsType GhcPs     -- Type variables.-    typ (LL _ (HsTyVar _ _ x))-      | Just (LL _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr' x) bind = y+    typ (L _ (HsTyVar _ _ x))+      | Just (L _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr' x) bind = y     typ x = x :: LHsType GhcPs  @@ -109,6 +112,65 @@ unifyDef' :: Data a => NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs)) unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y +unifyComposed' :: NameMatch'+               -> LHsExpr GhcPs+               -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+               -> Maybe (Subst' (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))+unifyComposed' nm x1 y11 dot y12 =+  ((, Just y11) <$> unifyExp' nm False x1 y12)+    <|> case y12 of+          (L _ (OpApp _ y121 dot' y122)) | isDot dot' ->+            unifyComposed' nm x1 (noLoc (OpApp noExtField y11 dot y121)) dot' y122+          _ -> Nothing++-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,+-- delegate to unifyExp'. These are the cases where we potentially need to call+-- unifyComposed' to handle left composition.+--+-- y is allowed to partially match x (the lhs of the hint), if y is a function application where+-- the function is a composition of functions. In this case the second component of the result is+-- the unmatched part of y, which will be attached to the rhs of the hint after substitution.+--+-- Example:+--   x = head (drop n x)+--   y = foo . bar . baz . head $ drop 2 xs+--   result = (Subst' [(n, 2), (x, xs)], Just (foo . bar . baz))+unifyExp :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))+-- Match wildcard operators.+unifyExp nm root (L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr' -> v))) rhs1))+                 (L _ (OpApp _ lhs2 (L _ (HsVar _ (rdrNameStr' -> op2))) rhs2))+    | isUnifyVar v =+        (, Nothing) . (Subst' [(v, strToVar op2)] <>) <$>+        liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)++-- Options: match directly, and expand through '.'+unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) =+    ((, Nothing) <$> liftA2 (<>) (unifyExp' nm False x1 y1) (unifyExp' nm False x2 y2)) <|> unifyComposed+  where+    -- Unify a function application where the function is a composition of functions.+    unifyComposed+      | (L _ (OpApp _ y11 dot y12)) <- fromParen' y1, isDot dot =+          -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.+          -- The guard ensures that you don't get duplicate matches because the matching engine+          -- auto-generates hints in dot-form.+          (guard (not root) >> (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2)))))+            -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',+            -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',+            -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.+            <|> do+                  rhs <- unifyExp' nm False x2 y2+                  (lhs, extra) <- unifyComposed' nm x1 y11 dot y12+                  pure (lhs <> rhs, extra)+      | otherwise = Nothing++-- Options: match directly, then expand through '$', then desugar infix.+unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2))+    | (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x =+        guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)+    | isDol op2 = unifyExp nm root x $ noLoc (HsApp noExtField lhs2 rhs2)+    | otherwise  = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 lhs2)) rhs2)+unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y+ -- App/InfixApp are analysed specially for performance reasons. If -- 'root = True', this is the outside of the expr. Do not expand out a -- dot at the root, since otherwise you get two matches because of@@ -119,67 +181,52 @@ unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen' x) y -- Don't subsitute for type apps, since no one writes rules imaginging -- they exist.-unifyExp' nm root (LL _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst' [(v, y)]-unifyExp' nm root (LL _ (HsVar _ x)) (LL _ (HsVar _ y)) | nm x y = Just mempty+unifyExp' nm root (L _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst' [(v, y)]+unifyExp' nm root (L _ (HsVar _ x)) (L _ (HsVar _ y)) | nm x y = Just mempty --- Match wildcard operators.-unifyExp' nm root (LL _ (OpApp _ lhs1 (LL _ (HsVar _ (rdrNameStr' -> v))) rhs1))-                  (LL _ (OpApp _ lhs2 (LL _ (HsVar _ (rdrNameStr' -> op2))) rhs2))-    | isUnifyVar v =-        (Subst' [(v, strToVar op2)] <>) <$>-        liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)-unifyExp' nm root (LL _ (SectionL _ exp1 (LL _ (HsVar _ (rdrNameStr' -> v)))))-                  (LL _ (SectionL _ exp2 (LL _ (HsVar _ (rdrNameStr' -> op2)))))+unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr' -> v))) rhs1))+                  y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) =+  fst <$> unifyExp nm root x y+unifyExp' nm root (L _ (SectionL _ exp1 (L _ (HsVar _ (rdrNameStr' -> v)))))+                  (L _ (SectionL _ exp2 (L _ (HsVar _ (rdrNameStr' -> op2)))))     | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2-unifyExp' nm root (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> v))) exp1))-                  (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> op2))) exp2))+unifyExp' nm root (L _ (SectionR _ (L _ (HsVar _ (rdrNameStr' -> v))) exp1))+                  (L _ (SectionR _ (L _ (HsVar _ (rdrNameStr' -> op2))) exp2))     | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 --- Options: match directly, and expand through '.'-unifyExp' nm root x@(LL _ (HsApp _ x1 x2)) (LL _ (HsApp _ y1 y2)) =-    liftM2 (<>) (unifyExp' nm False x1 y1) (unifyExp' nm False x2 y2) `mplus`-    (do guard $ not root-            -- Don't expand '.' f at the root, otherwise you can get-            -- duplicate matches because the matching engine-            -- auto-generates hints in dot-form.-        (LL _ (OpApp _ y11 dot y12)) <- return $ fromParen' y1-        guard $ isDot dot-        unifyExp' nm root x (noLoc (HsApp noExt y11 (noLoc (HsApp noExt y12 y2))))-    )+unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) =+  fst <$> unifyExp nm root x y --- Options: match directly, then expand through '$', then desugar infix.-unifyExp' nm root x (LL _ (OpApp _ lhs2 op2@(LL _ (HsVar _ op2')) rhs2))-    | (LL _ (OpApp _ lhs1 op1@(LL _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)-    | isDol op2 = unifyExp' nm root x $ noLoc (HsApp noExt lhs2 rhs2)-    | otherwise  = unifyExp' nm root x $ noLoc (HsApp noExt (noLoc (HsApp noExt op2 lhs2)) rhs2)+unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) =+  fst <$> unifyExp nm root x y  unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y     where         -- Types that are not already handled in unify.         {-# INLINE isOther #-}         isOther :: LHsExpr GhcPs -> Bool-        isOther (LL _ HsVar{}) = False-        isOther (LL _ HsApp{}) = False-        isOther (LL _ OpApp{}) = False+        isOther (L _ HsVar{}) = False+        isOther (L _ HsApp{}) = False+        isOther (L _ OpApp{}) = False         isOther _ = True  unifyExp' _ _ _ _ = Nothing   unifyPat' :: NameMatch' -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))-unifyPat' nm (LL _ (VarPat _ x)) (LL _ (VarPat _ y)) =+unifyPat' nm (L _ (VarPat _ x)) (L _ (VarPat _ y)) =   Just $ Subst' [(rdrNameStr' x, strToVar(rdrNameStr' y))]-unifyPat' nm (LL _ (VarPat _ x)) (LL _ (WildPat _)) =+unifyPat' nm (L _ (VarPat _ x)) (L _ (WildPat _)) =   let s = rdrNameStr' x in Just $ Subst' [(s, strToVar("_" ++ s))]-unifyPat' nm (LL _ (ConPatIn x _)) (LL _ (ConPatIn y _)) | rdrNameStr' x /= rdrNameStr' y =+unifyPat' nm (L _ (ConPatIn x _)) (L _ (ConPatIn y _)) | rdrNameStr' x /= rdrNameStr' y =   Nothing unifyPat' nm x y =   unifyDef' nm x y  unifyType' :: NameMatch' -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))-unifyType' nm (LL loc (HsTyVar _ _ x)) y =-  let wc = HsWC noExt y :: LHsWcType (NoGhcTc GhcPs)-      unused = noLoc (HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc "__unused__"))) :: LHsExpr GhcPs-      appType = cL loc (HsAppType noExt unused wc) :: LHsExpr GhcPs+unifyType' nm (L loc (HsTyVar _ _ x)) y =+  let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs)+      unused = noLoc (HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "__unused__"))) :: LHsExpr GhcPs+      appType = cL loc (HsAppType noExtField unused wc) :: LHsExpr GhcPs  in Just $ Subst' [(rdrNameStr' x, appType)] unifyType' nm x y = unifyDef' nm x y

@@ -1,23 +1,25 @@-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}  module GHC.Util.View (-   fromParen', fromPParen'+   fromParen'   , View'(..)   , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2'),LamConst1'(LamConst1')+  , pattern SimpleLambda ) where -import HsSyn+import GHC.Hs import SrcLoc import RdrName import OccName import BasicTypes+import GHC.Util.RdrName (rdrNameStr')  fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs-fromParen' (LL _ (HsPar _ x)) = fromParen' x+fromParen' (L _ (HsPar _ x)) = fromParen' x fromParen' x = x -fromPParen' :: Pat GhcPs -> Pat GhcPs-fromPParen' (LL _ (ParPat _ x)) = fromPParen' x+fromPParen' :: LPat GhcPs -> LPat GhcPs+fromPParen' (L _ (ParPat _ x)) = fromPParen' x fromPParen' x = x  class View' a b where@@ -25,31 +27,35 @@  data Var_'  = NoVar_' | Var_' String deriving Eq data PVar_' = NoPVar_' | PVar_' String-data PApp_' = NoPApp_' | PApp_' String [Pat GhcPs]+data PApp_' = NoPApp_' | PApp_' String [LPat GhcPs] data App2'  = NoApp2'  | App2' (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs) data LamConst1' = NoLamConst1' | LamConst1' (LHsExpr GhcPs)  instance View' (LHsExpr GhcPs) LamConst1' where-  view' (fromParen' -> (LL _ (HsLam _ (MG _ (L _ [LL _ (Match _ LambdaExpr [LL _ WildPat {}]-    (GRHSs _ [LL _ (GRHS _ [] x)] (LL _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x+  view' (fromParen' -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]+    (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x   view' _ = NoLamConst1'  instance View' (LHsExpr GhcPs) Var_' where-    view' (fromParen' -> (LL _ (HsVar _ (LL _ (Unqual x))))) = Var_' $ occNameString x+    view' (fromParen' -> (L _ (HsVar _ (rdrNameStr' -> x)))) = Var_' 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' (fromParen' -> L _ (OpApp _ lhs op rhs)) = App2' op lhs rhs+  view' (fromParen' -> L _ (HsApp _ (L _ (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)+instance View' (Located (Pat GhcPs)) PVar_' where+  view' (fromPParen' -> L _ (VarPat _ (L _ x))) = PVar_' $ occNameString (rdrNameOcc x)   view' _ = NoPVar_' -instance View' (Pat GhcPs) PApp_' where-  view' (fromPParen' -> LL _ (ConPatIn (L _ x) (PrefixCon args))) =+instance View' (Located (Pat GhcPs)) PApp_' where+  view' (fromPParen' -> L _ (ConPatIn (L _ x) (PrefixCon args))) =     PApp_' (occNameString . rdrNameOcc $ x) args-  view' (fromPParen' -> LL _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =+  view' (fromPParen' -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =     PApp_' (occNameString . rdrNameOcc $ x) [lhs, rhs]   view' _ = NoPApp_'++-- A lambda with no guards and no where clauses+pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs+pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _))

@@ -10,29 +10,32 @@ import Util import Idea -import qualified HsSyn as GHC+import qualified GHC.Hs as GHC import qualified BasicTypes as GHC+import qualified Outputable+import qualified ErrUtils+import Lexer import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import SrcLoc as GHC hiding (mkSrcSpan)+import GHC.Util.DynFlags+import Bag  runGrep :: String -> ParseFlags -> [FilePath] -> IO () runGrep patt flags files = do-    exp <- case parseExp patt of-        ParseOk x -> return x-        ParseFailed sl msg ->-            exitMessage $ (if "Parse error" `isPrefixOf` msg then msg else "Parse error in pattern: " ++ msg) ++ "\n" ++-                          patt ++ "\n" ++-                          replicate (srcColumn sl - 1) ' ' ++ "^"-    let scope = scopeCreate $ Module an Nothing [] [] []-    let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed-    let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing []-                         -- Todo : Replace these with "proper" GHC expressions.-                          (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing]+    exp <- case parseExpGhcWithMode flags patt of+        POk _ a -> pure a+        PFailed ps -> exitMessage $+          let (_, errs) = getMessages ps baseDynFlags+              errMsg = head (bagToList errs)+              msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg+          in "Failed to parse " ++ msg ++ ", when parsing:\n " ++ patt+    let ghcUnit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExtField [] GHC.Boxed+    let rule = hintRules [HintRule Suggestion "grep" [] mempty (extendInstances exp) (extendInstances ghcUnit) Nothing]     forM_ files $ \file -> do         res <- parseModuleEx flags file Nothing         case res of             Left (ParseError sl msg ctxt) ->-                print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []+                print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) sl ctxt Nothing []             Right m ->                 forM_ (applyHints [] rule [m]) $ \i ->                     print i{ideaHint="", ideaTo=Nothing}

@@ -1,13 +1,14 @@ {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}  module HLint(hlint, readAllSettings) where  import Control.Applicative import Control.Monad.Extra-import Control.Exception+import Control.Exception.Extra import Control.Concurrent.Extra import System.Console.CmdArgs.Verbosity+import GHC.Util.DynFlags import Data.List.Extra import GHC.Conc import System.Exit@@ -16,11 +17,6 @@ import Data.Tuple.Extra import Prelude -import Data.Version.Extra-import System.Process.Extra-import Data.Maybe-import System.Directory- import CmdLine import Config.Read import Config.Type@@ -31,6 +27,7 @@ import Test.All import Hint.All import Grep+import Refact import Timing import Test.Proof import Parallel@@ -53,6 +50,7 @@ --   on your server with untrusted input. hlint :: [String] -> IO [Idea] hlint args = do+    initGlobalDynFlags     cmd <- getCmd args     case cmd of         CmdMain{} -> do@@ -61,27 +59,9 @@             when (cmdTiming cmd) $ do                 printTimings                 putStrLn $ "Took " ++ showDuration time-            return $ if cmdNoExitCode cmd then [] else xs-        CmdGrep{} -> hlintGrep cmd >> return []-        CmdHSE{}  -> hlintHSE  cmd >> return []-        CmdTest{} -> hlintTest cmd >> return []--hlintHSE :: Cmd -> IO ()-hlintHSE c@CmdHSE{..} = do-    v <- getVerbosity-    forM_ cmdFiles $ \x -> do-        putStrLn $ "Parse result of " ++ x ++ ":"-        let (lang,exts) = cmdExtensions c-        -- We deliberately don't use HSE.All here to avoid any bugs in HLint-        -- polluting our bug reports (which is the main use of HSE)-        res <- parseFileWithMode defaultParseMode{baseLanguage=lang, extensions=exts} x-        case res of-            x@ParseFailed{} -> print x-            ParseOk m -> case v of-                Loud -> print m-                Quiet -> print $ prettyPrint m-                _ -> print $ void m-        putStrLn ""+            pure $ if cmdNoExitCode cmd then [] else xs+        CmdGrep{} -> hlintGrep cmd >> pure []+        CmdTest{} -> hlintTest cmd >> pure []  hlintTest :: Cmd -> IO () hlintTest cmd@CmdTest{..} =@@ -104,7 +84,7 @@      else do         files <- concatMapM (resolveFile cmd Nothing) cmdFiles         if null files then-            error "No files found"+            errorIO "No files found"          else             runGrep cmdPattern (cmdParseFlags cmd) files @@ -116,7 +96,7 @@ hlintMain :: [String] -> Cmd -> IO [Idea] hlintMain args cmd@CmdMain{..}     | cmdDefault = do-        ideas <- if null cmdFiles then return [] else withVerbosity Quiet $+        ideas <- if null cmdFiles then pure [] else withVerbosity Quiet $             runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing         let bad = nubOrd $ map ideaHint ideas         if null bad then putStr defaultYaml else do@@ -124,10 +104,10 @@             let group2 = "# Warnings currently triggered by your code" :                          ["- ignore: {name: " ++ show x ++ "}" | x <- bad]             putStr $ unlines $ intercalate ["",""] $ group1:group2:groups-        return []+        pure []     | null cmdFiles && not (null cmdFindHints) = do         hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints-        mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> return []+        mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> pure []     | null cmdFiles =         exitWithHelp     | cmdRefactor =@@ -154,13 +134,12 @@     settings1 <-         readFilesConfig $         files-        ++ [("CommandLine.hs",Just x) | x <- cmdWithHints]         ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups]     let args2 = [x | SettingArgument x <- settings1]-    cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last+    cmd@CmdMain{..} <- if null args2 then pure cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last     settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints-    settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]-    return (cmd, settings1 ++ settings2 ++ settings3)+    let settings3 = [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]+    pure (cmd, settings1 ++ settings2 ++ settings3)     where         enableGroup groupName =             unlines@@ -171,11 +150,11 @@  runHints :: [String] -> [Setting] -> Cmd -> IO [Idea] runHints args settings cmd@CmdMain{..} = do-    j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads+    j <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads     withNumCapabilities j $ do         let outStrLn = whenNormal . putStrLn         ideas <- getIdeas cmd settings-        ideas <- return $ if cmdShowAll then ideas else  filter (\i -> ideaSeverity i /= Ignore) ideas+        ideas <- pure $ if cmdShowAll then ideas else  filter (\i -> ideaSeverity i /= Ignore) ideas         if cmdJson then             putStrLn $ showIdeasJson ideas          else if cmdCC then@@ -187,19 +166,19 @@             handleRefactoring ideas cmdFiles cmd          else do             usecolour <- cmdUseColour cmd-            showItem <- if usecolour then showANSI else return show+            showItem <- if usecolour then showANSI else pure show             mapM_ (outStrLn . showItem) ideas             handleReporting ideas cmd-        return ideas+        pure ideas  getIdeas :: Cmd -> [Setting] -> IO [Idea] getIdeas cmd@CmdMain{..} settings = do-    settings <- return $ settings ++ map (Builtin . fst) builtinHints+    settings <- pure $ settings ++ map (Builtin . fst) builtinHints     let flags = cmdParseFlags cmd     ideas <- if cmdCross         then applyHintFiles flags settings cmdFiles         else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]-    return $ if not (null cmdOnly)+    pure $ if not (null cmdOnly)         then [i | i <- ideas, ideaHint i `elem` cmdOnly]         else ideas @@ -215,7 +194,7 @@             withTempFile $ \f -> do                 writeFile f hints                 exitWith =<< runRefactoring path file f cmdRefactorOptions-        _ -> error "Refactor flag can only be used with an individual file"+        _ -> errorIO "Refactor flag can only be used with an individual file"   handleReporting :: [Idea] -> Cmd -> IO ()@@ -228,28 +207,7 @@         let n = length showideas         outStrLn $ if n == 0 then "No hints" else show n ++ " hint" ++ ['s' | n/=1] -runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode-runRefactoring rpath fin hints opts =  do-    let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]-    (_, _, _, phand) <- createProcess $ proc rpath args-    try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())-    hSetBuffering stdout LineBuffering-    -- Propagate the exit code from the spawn process-    waitForProcess phand--checkRefactor :: Maybe FilePath -> IO FilePath-checkRefactor rpath = do-    let excPath = fromMaybe "refactor" rpath-    mexc <- findExecutable excPath-    case mexc of-        Just exc ->  do-            ver <- readVersion . tail <$> readProcess exc ["--version"] ""-            if versionBranch ver >= [0,1,0,0]-                then return exc-                else error "Your version of refactor is too old, please upgrade to the latest version"-        Nothing -> error $ unlines [ "Could not find refactor", "Tried with: " ++ excPath ]- evaluateList :: [a] -> IO [a] evaluateList xs = do     evaluate $ length xs-    return xs+    pure xs

@@ -1,24 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}  module HSE.All(-    module X,     CppFlags(..), ParseFlags(..), defaultParseFlags,     parseFlagsAddFixities, parseFlagsSetLanguage,     ParseError(..), ModuleEx(..),     parseModuleEx, ghcComments,-    freeVars, vars, varss, pvars,-    ghcSpanToHSE, ghcSrcLocToHSE,-    parseExpGhcWithMode, parseImportDeclGhcWithMode+    parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,     ) where -import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))-import qualified Language.Haskell.Exts.Util as X-import HSE.Util as X-import HSE.Type as X-import HSE.Match as X-import HSE.Scope as X import Util import Data.Char import Data.List.Extra@@ -26,57 +16,29 @@ import Timing import Language.Preprocessor.Cpphs import Data.Either-import Data.Set (Set)+import DynFlags(Language(..)) import qualified Data.Map as Map-import qualified Data.Set as Set import System.IO.Extra import Data.Functor+import Fixity+import Extension+import FastString import Prelude -import qualified HsSyn-import qualified FastString+import GHC.Hs import qualified SrcLoc as GHC-import qualified ErrUtils+import ErrUtils import qualified Outputable import qualified Lexer as GHC-import qualified GHC.LanguageExtensions.Type as GHC+import GHC.LanguageExtensions.Type import qualified ApiAnnotation as GHC import qualified BasicTypes as GHC import qualified DynFlags as GHC+import Bag -import GHC.Util+import GHC.Util (parsePragmasIntoDynFlags, parseFileGhcLib, parseExpGhcLib, parseDeclGhcLib, parseImportGhcLib, baseDynFlags) import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx --- | Convert a GHC source loc into an HSE equivalent.-ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc-ghcSrcLocToHSE (GHC.RealSrcLoc l) =-  SrcLoc {-      srcFilename = FastString.unpackFS (GHC.srcLocFile l)-    , srcLine = GHC.srcLocLine l-    , srcColumn = GHC.srcLocCol l-    }-ghcSrcLocToHSE (GHC.UnhelpfulLoc _) = noLoc---- | Convert a GHC source span into an HSE equivalent.-ghcSpanToHSE :: GHC.SrcSpan -> SrcSpan-ghcSpanToHSE (GHC.RealSrcSpan s) =-  SrcSpan {-      srcSpanFilename = FastString.unpackFS (GHC.srcSpanFile s)-    , srcSpanStartLine = GHC.srcSpanStartLine s-    , srcSpanStartColumn = GHC.srcSpanStartCol s-    , srcSpanEndLine = GHC.srcSpanEndLine s-    , srcSpanEndColumn = GHC.srcSpanEndCol s-    }-ghcSpanToHSE (GHC.UnhelpfulSpan _) = mkSrcSpan noLoc noLoc--vars :: FreeVars a => a -> [String]-freeVars :: FreeVars a => a -> Set String-varss, pvars :: AllVars a => a -> [String]-vars  = Set.toList . Set.map prettyPrint . X.freeVars-varss = Set.toList . Set.map prettyPrint . X.free . X.allVars-pvars = Set.toList . Set.map prettyPrint . X.bound . X.allVars-freeVars = Set.map prettyPrint . X.freeVars- -- | What C pre processor should be used. data CppFlags     = NoCpp -- ^ No pre processing is done.@@ -86,93 +48,26 @@ -- | Created with 'defaultParseFlags', used by 'parseModuleEx'. data ParseFlags = ParseFlags     {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').-    ,hseFlags :: ParseMode -- ^ How the file is parsed (defaults to all fixities in the @base@ package and most non-conflicting extensions).+    ,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.+    ,extensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.+    ,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.     } -lensFixities :: [Fixity]-lensFixities = concat-    -- List as provided at https://github.com/ndmitchell/hlint/issues/416-    [infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","<//~","<^~","<^^~","<**~"]-    ,infix_ 4 ["%%@=","<%@=","%%=","<+=","<*=","<-=","<//=","<^=","<^^=","<**="]-    ,infixr_ 2 ["<<~"]-    ,infixr_ 9 ["#."]-    ,infixl_ 8 [".#"]-    ,infixr_ 8 ["^!","^@!"]-    ,infixl_ 1 ["&","<&>","??"]-    ,infixl_ 8 ["^.","^@."]-    ,infixr_ 9 ["<.>","<.",".>"]-    ,infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"]-    ,infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="]-    ,infixr_ 2 ["<~"]-    ,infixr_ 2 ["`zoom`","`magnify`"]-    ,infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"]-    ,infixl_ 8 ["^#"]-    ,infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"]-    ,infix_ 4 ["<#=","#=","#%=","<#%=","#%%="]-    ,infixl_ 9 [":>"]-    ,infixr_ 4 ["</>~","<</>~","<.>~","<<.>~"]-    ,infix_ 4 ["</>=","<</>=","<.>=","<<.>="]-    ,infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"]-    ,infix_ 4 [".|.=",".&.=","<.|.=","<.&.="]-    ]--otherFixities :: [Fixity]-otherFixities = concat-    -- hspec-    [infix_ 1 ["`shouldBe`","`shouldSatisfy`","`shouldStartWith`","`shouldEndWith`","`shouldContain`","`shouldMatchList`"-              ,"`shouldReturn`","`shouldNotBe`","`shouldNotSatisfy`","`shouldNotContain`","`shouldNotReturn`","`shouldThrow`"]-    -- quickcheck-    ,infixr_ 0 ["==>"]-    ,infix_ 4 ["==="]-    -- esqueleto-    ,infix_ 4 ["==."]-    -- lattices-    ,infixr_ 5 ["\\/"] -- \/-    ,infixr_ 6 ["/\\"] -- /\-    ]---- Fixites from the `base` package which are currently--- missing from `haskell-src-exts`'s baseFixities.--- see https://github.com/haskell-suite/haskell-src-exts/pull/400-baseNotYetInHSE :: [Fixity]-baseNotYetInHSE = concat-    [infixr_ 9 ["`Compose`"]-    ,infixr_ 6 ["<>"]-    ,infixr_ 5 ["<|"]-    ,infixl_ 4 ["<$!>","<$","$>"]-    ,infix_ 4 [":~:", ":~~:"]-    ]--customFixities :: [Fixity]-customFixities =-    infixl_ 1 ["`on`"]-        -- see https://github.com/ndmitchell/hlint/issues/425-        -- otherwise GTK apps using `on` at a different fixity have spurious warnings- -- | Default value for 'ParseFlags'. defaultParseFlags :: ParseFlags-defaultParseFlags = ParseFlags NoCpp defaultParseMode-    {fixities = Just $ customFixities ++ baseFixities ++ baseNotYetInHSE ++ lensFixities ++ otherFixities-    ,ignoreLinePragmas = False-    ,ignoreFunctionArity = True-    ,extensions = parseExtensions}--parseFlagsNoLocations :: ParseFlags -> ParseFlags-parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y}-    where f x = x{boolopts = (boolopts x){locations=False}}+defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions defaultFixities  -- | Given some fixities, add them to the existing fixities in 'ParseFlags'.-parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags-parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}}-    where hse = hseFlags x+parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags+parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x} -parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags-parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags x){baseLanguage = l, extensions = es}}+parseFlagsSetLanguage :: (Maybe Language, [Extension]) -> ParseFlags -> ParseFlags+parseFlagsSetLanguage (l, es) x = x{baseLanguage = l, extensions = es}   runCpp :: CppFlags -> FilePath -> String -> IO String-runCpp NoCpp _ x = return x-runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]+runCpp NoCpp _ x = pure x+runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x] runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x     where         -- LINE pragmas always inserted when locations=True@@ -184,16 +79,14 @@  -- | A parse error. data ParseError = ParseError-    { parseErrorLocation :: SrcLoc -- ^ Location of the error.+    { parseErrorLocation :: GHC.SrcSpan -- ^ Location of the error.     , parseErrorMessage :: String  -- ^ Message about the cause of the error.     , parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.     }  -- | Result of 'parseModuleEx', representing a parsed module. data ModuleEx = ModuleEx {-    hseModule :: Module SrcSpanInfo-  , hseComments :: [Comment]-  , ghcModule :: GHC.Located (HsSyn.HsModule HsSyn.GhcPs)+    ghcModule :: GHC.Located (HsModule GhcPs)   , ghcAnnotations :: GHC.ApiAnns } @@ -201,48 +94,7 @@ ghcComments :: ModuleEx -> [GHC.Located GHC.AnnotationComment] ghcComments m = concat (Map.elems $ snd (ghcAnnotations m)) --- | Utility called from 'parseModuleEx' and 'hseFailOpParseModuleEx'.-mkMode :: ParseFlags -> String -> ParseMode-mkMode flags file = (hseFlags flags){ parseFilename = file,fixities = Nothing } --- | Error handler dispatcher. Invoked when HSE parsing has failed.-failOpParseModuleEx :: String-                    -> ParseFlags-                    -> FilePath-                    -> String-                    -> SrcLoc-                    -> String-                    -> Maybe (GHC.SrcSpan, ErrUtils.MsgDoc)-                    -> IO (Either ParseError ModuleEx)-failOpParseModuleEx ppstr flags file str sl msg ghc =-   case ghc of-     Just err ->-       -- GHC error info is available (assumed to have come from a-       -- 'PFailed'). We prefer to construct a 'ParseError' value-       -- using that.-       ghcFailOpParseModuleEx ppstr file str err-     Nothing ->-       -- No GHC error info provided. This is the traditional approach-       -- to handling errors.-       hseFailOpParseModuleEx ppstr flags file str sl msg---- | An error handler of last resort. This is invoked when HSE parsing--- has failed but apparently GHC has not!-hseFailOpParseModuleEx :: String-                       -> ParseFlags-                       -> FilePath-                       -> String-                       -> SrcLoc-                       -> String-                       -> IO (Either ParseError ModuleEx)-hseFailOpParseModuleEx ppstr flags file str sl msg = do-    flags <- return $ parseFlagsNoLocations flags-    ppstr2 <- runCpp (cppFlags flags) file str-    let pe = case parseFileContentsWithMode (mkMode flags file) ppstr2 of-               ParseFailed sl2 _ -> context (srcLine sl2) ppstr2-               _ -> context (srcLine sl) ppstr-    return $ Left $ ParseError sl msg pe- -- | The error handler invoked when GHC parsing has failed. ghcFailOpParseModuleEx :: String                        -> FilePath@@ -250,174 +102,95 @@                        -> (GHC.SrcSpan, ErrUtils.MsgDoc)                        -> IO (Either ParseError ModuleEx) ghcFailOpParseModuleEx ppstr file str (loc, err) = do-   let sl =-         case loc of-           GHC.RealSrcSpan r ->-             SrcLoc { srcFilename = FastString.unpackFS (GHC.srcSpanFile r)-                     , srcLine = GHC.srcSpanStartLine r-                     , srcColumn = GHC.srcSpanStartCol r }-           GHC.UnhelpfulSpan _ ->-             SrcLoc { srcFilename = file-                     , srcLine = 1 :: Int-                     , srcColumn = 1 :: Int }-       pe = context (srcLine sl) ppstr-       msg = Outputable.showSDoc baseDynFlags $-               ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)-   return $ Left $ ParseError sl msg pe---- A hacky function to get fixities from HSE parse flags suitable for--- use by our own 'GHC.Util.Refact.Fixity' module.-ghcFixitiesFromParseMode :: ParseMode -> [(String, GHC.Fixity)]-ghcFixitiesFromParseMode 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 _ = ""-ghcFixitiesFromParseMode _ = []---- GHC enabled/disabled extensions given an HSE parse mode.-ghcExtensionsFromParseMode :: ParseMode-                           -> ([GHC.Extension], [GHC.Extension])-ghcExtensionsFromParseMode ParseMode {extensions=exts}=-   partitionEithers $ mapMaybe toEither exts-   where-     toEither ke = case ke of-       EnableExtension e  -> Left  <$> readExtension (show e)-       DisableExtension e -> Right <$> readExtension (show e)-       UnknownExtension ('N':'o':e) -> Right <$> readExtension e-       UnknownExtension e -> Left <$> readExtension e+   let pe = case loc of+            GHC.RealSrcSpan r -> context (GHC.srcSpanStartLine r) ppstr+            _ -> ""+       msg = Outputable.showSDoc baseDynFlags err+   pure $ Left $ ParseError loc msg pe  -- GHC extensions to enable/disable given HSE parse flags.-ghcExtensionsFromParseFlags :: ParseFlags-                             -> ([GHC.Extension], [GHC.Extension])-ghcExtensionsFromParseFlags ParseFlags {hseFlags=mode} = ghcExtensionsFromParseMode mode+ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])+ghcExtensionsFromParseFlags ParseFlags{extensions=exts}= (exts, [])  -- GHC fixities given HSE parse flags. ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]-ghcFixitiesFromParseFlags ParseFlags {hseFlags=mode} = ghcFixitiesFromParseMode mode+ghcFixitiesFromParseFlags = map toFixity . fixities  -- These next two functions get called frorm 'Config/Yaml.hs' for user -- defined hint rules. -parseExpGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LHsExpr HsSyn.GhcPs)+parseModeToFlags :: ParseFlags -> GHC.DynFlags+parseModeToFlags parseMode =+    flip GHC.lang_set (baseLanguage parseMode) $ foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable+  where+    (enable, disable) = ghcExtensionsFromParseFlags parseMode++parseExpGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsExpr GhcPs) parseExpGhcWithMode parseMode s =-  let (enable, disable) = ghcExtensionsFromParseMode parseMode-      flags = foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable-      fixities = ghcFixitiesFromParseMode parseMode-  in case parseExpGhcLib s flags of+  let fixities = ghcFixitiesFromParseFlags parseMode+  in case parseExpGhcLib s $ parseModeToFlags parseMode of     GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a)     f@GHC.PFailed{} -> f -parseImportDeclGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LImportDecl HsSyn.GhcPs)+parseImportDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LImportDecl GhcPs) parseImportDeclGhcWithMode parseMode s =-  let (enable, disable) = ghcExtensionsFromParseMode parseMode-      flags = foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable-  in parseImportGhcLib s flags+  parseImportGhcLib s $ parseModeToFlags parseMode +parseDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsDecl GhcPs)+parseDeclGhcWithMode parseMode s =+  let fixities = ghcFixitiesFromParseFlags parseMode+  in case parseDeclGhcLib s $ parseModeToFlags parseMode of+    GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a)+    f@GHC.PFailed{} -> f+ -- | 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 -- 'defaultParseFlags'), the filename, and optionally the contents of--- that file. This version uses both hs-src-exts AND ghc-lib.+-- that file. parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx) parseModuleEx flags file str = timedIO "Parse" file $ do         str <- case str of-            Just x -> return x+            Just x -> pure x             Nothing | file == "-" -> getContentsUTF8                     | otherwise -> readFileUTF8' file-        str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130+        str <- pure $ dropPrefix "\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.+            fixities = ghcFixitiesFromParseFlags 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), GHC.POk pst a) ->+          Right ghcFlags -> do+            ghcFlags <- pure $ GHC.lang_set ghcFlags $ baseLanguage flags+            case parseFileGhcLib file ppstr ghcFlags of+                GHC.POk pst a ->                     let anns =                           ( Map.fromListWith (++) $ GHC.annotations pst                           , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pst) : GHC.annotations_comments pst)                           ) in                     let a' = GhclibParserEx.applyFixities fixities a in-                    return $ Right (ModuleEx (applyFixity fixity x) cs a' anns)+                    pure $ Right (ModuleEx a' anns)                 -- Parse error if GHC parsing fails (see                 -- https://github.com/ndmitchell/hlint/issues/645).-                (ParseOk _,  GHC.PFailed _ loc err) ->-                    ghcFailOpParseModuleEx ppstr file str (loc, err)-                (ParseFailed sl msg, pfailed) ->-                    failOpParseModuleEx ppstr flags file str sl msg $ fromPFailed pfailed+                GHC.PFailed s -> do+                    let (_, errs) = GHC.getMessages s ghcFlags+                        errMsg = head (bagToList errs)+                        loc = errMsgSpan errMsg+                        doc = formatErrDoc ghcFlags (errMsgDoc errMsg)+                    ghcFailOpParseModuleEx ppstr file str (loc, doc)           Left msg -> do             -- Parsing GHC flags from dynamic pragmas in the source             -- has failed. When this happens, it's reported by             -- exception. It's impossible or at least fiddly getting a             -- location so we skip that for now. Synthesize a parse             -- error.-            let loc = SrcLoc file (1 :: Int) (1 :: Int)-            return $ Left (ParseError loc msg (context (srcLine loc) ppstr))+            let loc = GHC.mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)+            pure $ Left (ParseError (GHC.mkSrcSpan loc loc) msg ppstr) -    where-        fromPFailed (GHC.PFailed _ loc err) = Just (loc, err)-        fromPFailed _ = Nothing -        fixity = fromMaybe [] $ fixities $ hseFlags flags- -- | Given a line number, and some source code, put bird ticks around the appropriate bit. context :: Int -> String -> String context lineNo src =     unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $     zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]-    where ticks = ["  ","  ","> ","  ","  "]--------------------------------------------------------------------------- FIXITIES---- resolve fixities later, so we don't ever get uncatchable ambiguity errors--- if there are fixity errors, try the cheapFixities (which never fails)-applyFixity :: [Fixity] -> Module_ -> Module_-applyFixity base modu = descendBi f modu-    where-        f x = fromMaybe (cheapFixities fixs x) $ applyFixities fixs x :: Decl_-        fixs = concatMap getFixity (moduleDecls modu) ++ base----- Apply fixities, but ignoring any ambiguous fixity errors and skipping qualified names,--- local infix declarations etc. Only use as a backup, if HSE gives an error.------ Inspired by the code at:--- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs-cheapFixities :: [Fixity] -> Decl_ -> Decl_-cheapFixities fixs = descendBi (transform f)-    where-        ask = askFixity fixs--        f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z)-                | p1 == p2 && (a1 /= a2 || isAssocNone a1) = o -- Ambiguous infix expression!-                | p1 > p2 || p1 == p2 && (isAssocLeft a1 || isAssocNone a2) = o-                | otherwise = InfixApp s1 x op1 (f $ InfixApp s1 y op2 z)-            where-                (a1,p1) = ask op1-                (a2,p2) = ask op2-        f x = x---askFixity :: [Fixity] -> QOp S -> (Assoc (), Int)-askFixity xs = \k -> Map.findWithDefault (AssocLeft (), 9) (fromNamed k) mp-    where-        mp = Map.fromList [(s,(a,p)) | Fixity a p x <- xs, let s = fromNamed $ fmap (const an) x, s /= ""]+    where ticks = drop (3 - lineNo) ["  ","  ","> ","  ","  "]

@@ -1,142 +0,0 @@-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}--module HSE.Match(-    View(..), Named(..),-    (~=), isSym,-    App2(App2), PVar_(PVar_), Var_(Var_)-    ) where--import Data.Char-import HSE.Type-import HSE.Util---class View a b where-    view :: a -> b---data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show--instance View Exp_ App2 where-    view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs-    view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y-    view _ = NoApp2---data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show--instance View Exp_ App1 where-    view (fromParen -> App _ f x) = App1 f x-    view _ = NoApp1--data PVar_ = NoPVar_ | PVar_ String--instance View Pat_ PVar_ where-    view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x-    view _ = NoPVar_--data Var_ = NoVar_ | Var_ String deriving Eq--instance View Exp_ Var_ where-    view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x-    view _ = NoVar_---(~=) :: Named a => a -> String -> Bool-(~=) = (==) . fromNamed----- | fromNamed will return \"\" when it cannot be represented---   toNamed may crash on \"\"-class Named a where-    toNamed :: String -> a-    fromNamed :: a -> String---isCtor (x:_) = isUpper x || x == ':'-isCtor _ = False--isSym (x:_) = not $ isAlpha x || x `elem` "_'"-isSym _ = False---instance Named (Exp S) where-    fromNamed (Var _ x) = fromNamed x-    fromNamed (Con _ x) = fromNamed x-    fromNamed (List _ []) = "[]"-    fromNamed _ = ""--    toNamed "[]" = List an []-    toNamed x | isCtor x = Con an $ toNamed x-              | otherwise = Var an $ toNamed x--instance Named (QName S) where-    fromNamed (Special _ Cons{}) = ":"-    fromNamed (Special _ UnitCon{}) = "()"-    fromNamed (UnQual _ x) = fromNamed x-    fromNamed _ = ""--    toNamed ":" = Special an $ Cons an-    toNamed x = UnQual an $ toNamed x--instance Named (Name S) where-    fromNamed (Ident _ x) = x-    fromNamed (Symbol _ x) = x--    toNamed x | isSym x = Symbol an x-              | otherwise = Ident an x--instance Named (ModuleName S) where-    fromNamed (ModuleName _ x) = x-    toNamed = ModuleName an---instance Named (Pat S) where-    fromNamed (PVar _ x) = fromNamed x-    fromNamed (PApp _ x []) = fromNamed x-    fromNamed (PList _ []) = "[]"-    fromNamed _ = ""--    toNamed x | isCtor x = PApp an (toNamed x) []-              | otherwise = PVar an $ toNamed x---instance Named (TyVarBind S) where-    fromNamed (KindedVar _ x _) = fromNamed x-    fromNamed (UnkindedVar _ x) = fromNamed x-    toNamed x = UnkindedVar an (toNamed x)---instance Named (QOp S) where-    fromNamed (QVarOp _ x) = fromNamed x-    fromNamed (QConOp _ x) = fromNamed x-    toNamed x | isCtor x = QConOp an $ toNamed x-              | otherwise = QVarOp an $ toNamed x--instance Named (Match S) where-    fromNamed (Match _ x _ _ _) = fromNamed x-    fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x-    toNamed = error "No toNamed for Match"--instance Named (DeclHead S) where-    fromNamed (DHead _ x) = fromNamed x-    fromNamed (DHInfix _ _ x) = fromNamed x-    fromNamed (DHParen _ x) = fromNamed x-    fromNamed (DHApp _ x _) = fromNamed x-    toNamed = error "No toNamed for DeclHead"--instance Named (Decl S) where-    fromNamed (TypeDecl _ name _) = fromNamed name-    fromNamed (DataDecl _ _ _ name _ _) = fromNamed name-    fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name-    fromNamed (TypeFamDecl _ name _ _) = fromNamed name-    fromNamed (DataFamDecl _ _ name _) = fromNamed name-    fromNamed (ClassDecl _ _ name _ _) = fromNamed name-    fromNamed (PatBind _ (PVar _ name) _ _) = fromNamed name-    fromNamed (FunBind _ (name:_)) = fromNamed name-    fromNamed (ForImp _ _ _ _ name _) = fromNamed name-    fromNamed (ForExp _ _ _ name _) = fromNamed name-    fromNamed (TypeSig _ (name:_) _) = fromNamed name-    fromNamed _ = ""--    toNamed = error "No toNamed for Decl"

@@ -1,48 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module HSE.Scope(-    Scope, scopeCreate, scopeImports-    ) where--import Data.Semigroup-import HSE.Type-import HSE.Util-import Data.List-import Data.Maybe-import Prelude--{--the hint file can do:--import Prelude (filter)-import Data.List (filter)-import List (filter)--then filter on it's own will get expanded to all of them--import Data.List-import List as Data.List---if Data.List.head x ==> x, then that might match List too--}----- | Data type representing the modules in scope within a module.---   Created with 'scopeCreate' and queried with 'scopeMatch' and 'scopeMove'.---   Note that the 'mempty' 'Scope' is not equivalent to 'scopeCreate' on an empty module,---   due to the implicit import of 'Prelude'.-newtype Scope = Scope [ImportDecl S]-             deriving (Show, Monoid, Semigroup)---- | Create a 'Scope' value from a module, based on the modules imports.-scopeCreate :: Module SrcSpanInfo -> Scope-scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res-    where-        res = [x | x <- moduleImports xs, importPkg x /= Just "hint"]-        prelude = ImportDecl an (ModuleName an "Prelude") False False False Nothing Nothing Nothing-        isPrelude x = fromModuleName (importModule x) == "Prelude"---scopeImports :: Scope -> [ImportDecl S]-scopeImports (Scope x) = x

@@ -1,18 +0,0 @@--module HSE.Type(-    S,-    Module_, Decl_, Exp_, Pat_,-    module HSE,-    module Uniplate-    ) where---- Almost all from the Annotated module, but the fixity resolution from Annotated--- uses the unannotated Assoc enumeration, so export that instead-import Language.Haskell.Exts as HSE hiding (parse, loc, paren)-import Data.Generics.Uniplate.Data as Uniplate--type S = SrcSpanInfo-type Module_ = Module S-type Decl_ = Decl S-type Exp_ = Exp S-type Pat_ = Pat S

@@ -1,420 +0,0 @@-{-# LANGUAGE FlexibleContexts, TupleSections #-}--module HSE.Util(module HSE.Util, def) where--import Control.Monad-import Data.Default-import Data.Tuple.Extra-import Data.List-import Language.Haskell.Exts.Util-import Control.Monad.Trans.State-import qualified Data.Map as Map-import Data.Maybe-import Data.Data hiding (Fixity)-import System.FilePath-import HSE.Type-import Data.Functor-import Prelude--------------------------------------------------------------------------- ACCESSOR/TESTER--ellipses :: QName S-ellipses = UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol--opExp :: QOp S -> Exp_-opExp (QVarOp s op) = Var s op-opExp (QConOp s op) = Con s op--expOp :: Exp_ -> Maybe (QOp S)-expOp (Var s op) = Just $ QVarOp s op-expOp (Con s op) = Just $ QConOp s op-expOp _ = Nothing--moduleDecls :: Module_ -> [Decl_]-moduleDecls (Module _ _ _ _ xs) = xs-moduleDecls _ = [] -- XmlPage/XmlHybrid--moduleName :: Module_ -> String-moduleName (Module _ Nothing _ _ _) = "Main"-moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x-moduleName _ = "" -- XmlPage/XmlHybrid--moduleImports :: Module_ -> [ImportDecl S]-moduleImports (Module _ _ _ x _) = x-moduleImports _ = [] -- XmlPage/XmlHybrid--modulePragmas :: Module_ -> [ModulePragma S]-modulePragmas (Module _ _ x _ _) = x-modulePragmas _ = [] -- XmlPage/XmlHybrid--moduleExtensions :: Module_ -> [Name S]-moduleExtensions x = concat [y | LanguagePragma _ y <- modulePragmas x]--fromModuleName :: ModuleName S -> String-fromModuleName (ModuleName _ x) = x--fromChar :: Exp_ -> Maybe Char-fromChar (Lit _ (Char _ x _)) = Just x-fromChar _ = Nothing--fromPChar :: Pat_ -> Maybe Char-fromPChar (PLit _ _ (Char _ x _)) = Just x-fromPChar _ = Nothing--fromString :: Exp_ -> Maybe String-fromString (Lit _ (String _ x _)) = Just x-fromString _ = Nothing--fromPString :: Pat_ -> Maybe String-fromPString (PLit _ _ (String _ x _)) =  Just x-fromPString _ = Nothing--fromParen1 :: Exp_ -> Exp_-fromParen1 (Paren _ x) = x-fromParen1 x = x--fromParen :: Exp_ -> Exp_-fromParen (Paren _ x) = fromParen x-fromParen x = x--fromPParen :: Pat s -> Pat s-fromPParen (PParen _ x) = fromPParen x-fromPParen x = x--fromTyParen :: Type s -> Type s-fromTyParen (TyParen _ x) = fromTyParen x-fromTyParen x = x--fromTyBang :: Type s -> Type s-fromTyBang (TyBang _ _ _ x) = x-fromTyBang x = x---- is* :: Exp_ -> Bool--- is* :: Decl_ -> Bool-isVar Var{} = True; isVar _ = False-isCon Con{} = True; isCon _ = False-isApp App{} = True; isApp _ = False-isInfixApp InfixApp{} = True; isInfixApp _ = False-isAnyApp x = isApp x || isInfixApp x-isParen Paren{} = True; isParen _ = False-isIf If{} = True; isIf _ = False-isLambda Lambda{} = True; isLambda _ = False-isMDo MDo{} = True; isMDo _ = False-isBoxed Boxed{} = True; isBoxed _ = False-isDerivDecl DerivDecl{} = True; isDerivDecl _ = False-isPBangPat PBangPat{} = True; isPBangPat _ = False-isPFieldPun PFieldPun{} = True; isPFieldPun _ = False-isFieldPun FieldPun{} = True; isFieldPun _ = False-isPWildCard PWildCard{} = True; isPWildCard _ = False-isPFieldWildcard PFieldWildcard{} = True; isPFieldWildcard _ = False-isFieldWildcard FieldWildcard{} = True; isFieldWildcard _ = False-isPViewPat PViewPat{} = True; isPViewPat _ = False-isParComp ParComp{} = True; isParComp _ = False-isTypeApp TypeApp{} = True; isTypeApp _ = False-isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False-isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False-isTyQuasiQuote TyQuasiQuote{} = True; isTyQuasiQuote _ = False-isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False-isNewType NewType{} = True; isNewType _ = False-isRecStmt RecStmt{} = True; isRecStmt _ = False-isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False-isTyBang TyBang{} = True; isTyBang _ = False-isLCase LCase{} = True; isLCase _ = False-isTupleSection TupleSection{} = True; isTupleSection _ = False-isString String{} = True; isString _ = False-isRecUpdate RecUpdate{} = True; isRecUpdate _ = False-isRecConstr RecConstr{} = True; isRecConstr _ = False--isSection LeftSection{} = True-isSection RightSection{} = True-isSection _ = False--isPrimLiteral PrimInt{} = True-isPrimLiteral PrimWord{} = True-isPrimLiteral PrimFloat{} = True-isPrimLiteral PrimDouble{} = True-isPrimLiteral PrimChar{} = True-isPrimLiteral PrimString{} = True-isPrimLiteral _ = False---allowRightSection x = x `notElem` ["-","#"]-allowLeftSection x = x /= "#"---unqual :: QName S -> QName S-unqual (Qual an _ x) = UnQual an x-unqual x = x--fromQual :: QName a -> Maybe (Name a)-fromQual (Qual _ _ x) = Just x-fromQual (UnQual _ x) = Just x-fromQual _ = Nothing--isSpecial :: QName S -> Bool-isSpecial Special{} = True; isSpecial _ = False--isDol :: QOp S -> Bool-isDol (QVarOp _ (UnQual _ (Symbol _ "$"))) = True-isDol _ = False--isDot :: QOp S -> Bool-isDot (QVarOp _ (UnQual _ (Symbol _ "."))) = True-isDot _ = False--isDotApp :: Exp_ -> Bool-isDotApp (InfixApp _ _ dot _) | isDot dot = True-isDotApp _ = False--dotApp :: Exp_ -> Exp_ -> Exp_-dotApp x = InfixApp an x (QVarOp an $ UnQual an $ Symbol an ".")--dotApps :: [Exp_] -> Exp_-dotApps [] = error "HSE.Util.dotApps, does not work on an empty list"-dotApps [x] = x-dotApps (x:xs) = dotApp x (dotApps xs)--isReturn :: Exp_ -> Bool--- Allow both pure and return, as they have the same semantics-isReturn (Var _ (UnQual _ (Ident _ x))) = x == "return" || x == "pure"-isReturn _ = False--isLexeme Var{} = True-isLexeme Con{} = True-isLexeme Lit{} = True-isLexeme _ = False--isAssocLeft AssocLeft{} = True; isAssocLeft _ = False-isAssocNone AssocNone{} = True; isAssocNone _ = False--isWHNF :: Exp_ -> Bool-isWHNF Con{} = True-isWHNF (Lit _ x) = case x of String{} -> False; Int{} -> False; Frac{} -> False; _ -> True-isWHNF Lambda{} = True-isWHNF Tuple{} = True-isWHNF List{} = True-isWHNF (Paren _ x) = isWHNF x-isWHNF (ExpTypeSig _ x _) = isWHNF x--- other (unknown) constructors may have bang patterns in them, so approximate-isWHNF (App _ c@Con{} _) | prettyPrint c `elem` ["Just","Left","Right"] = True-isWHNF _ = False----- | Like needBracket, but with a special case for a . b . b, which---   was removed from haskell-src-exts-util-0.2.2-needBracketOld :: Int -> Exp_ -> Exp_ -> Bool-needBracketOld i parent child-    | isDotApp parent, isDotApp child, i == 1 = False-    | otherwise = needBracket i parent child--transformBracketOld :: (Exp_ -> Maybe Exp_) -> Exp_ -> Exp_-transformBracketOld op = snd . g-    where-        g = f . descendBracketOld g-        f x = maybe (False,x) (True,) (op x)---- | Descend, and if something changes then add/remove brackets appropriately-descendBracketOld :: (Exp_ -> (Bool, Exp_)) -> Exp_ -> Exp_-descendBracketOld op x = descendIndex g x-    where-        g i y = if a then f i b else b-            where (a,b) = op y--        f i (Paren _ y) | not $ needBracketOld i x y = y-        f i y           | needBracketOld i x y = addParen y-        f _ y           = y--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--------------------------------------------------------------------------- HSE FUNCTIONS--getEquations :: Decl s -> [Decl s]-getEquations (FunBind s xs) = map (FunBind s . (:[])) xs-getEquations x@PatBind{} = [toFunBind x]-getEquations x = [x]---toFunBind :: Decl s -> Decl s-toFunBind (PatBind s (PVar _ name) bod bind) = FunBind s [Match s name [] bod bind]-toFunBind x = x----- case and if both have branches, nothing else does-replaceBranches :: Exp s -> ([Exp s], [Exp s] -> Exp s)-replaceBranches (If s a b c) = ([b,c], \[b,c] -> If s a b c)-replaceBranches (Case s a bs) = (concatMap f bs, Case s a . g bs)-    where-        f (Alt _ _ (UnGuardedRhs _ x) _) = [x]-        f (Alt _ _ (GuardedRhss _ xs) _) = [x | GuardedRhs _ _ x <- xs]-        g (Alt s1 a (UnGuardedRhs s2 _) b:rest) (x:xs) = Alt s1 a (UnGuardedRhs s2 x) b : g rest xs-        g (Alt s1 a (GuardedRhss s2 ns) b:rest) xs =-                Alt s1 a (GuardedRhss s2 [GuardedRhs a b x | (GuardedRhs a b _,x) <- zip ns as]) b : g rest bs-            where (as,bs) = splitAt (length ns) xs-        g [] [] = []-        g _ _ = error "HSE.Util.replaceBranches: internal invariant failed, lists are of differing lengths"-replaceBranches x = ([], \[] -> x)--------------------------------------------------------------------------- VECTOR APPLICATION---apps :: [Exp_] -> Exp_-apps = foldl1 (App an)--fromApps :: Exp_ -> [Exp_]-fromApps = map fst . fromAppsWithLoc--fromAppsWithLoc :: Exp_ -> [(Exp_, S)]-fromAppsWithLoc (App l x y) = fromAppsWithLoc x ++ [(y, l)]-fromAppsWithLoc x = [(x, ann x)]----- Rule for the Uniplate Apps functions--- Given (f a) b, consider the children to be: children f ++ [a,b]--childrenApps :: Exp_ -> [Exp_]-childrenApps (App s x y) = childrenApps x ++ [y]-childrenApps x = children x---descendApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_-descendApps f (App s x y) = App s (descendApps f x) (f y)-descendApps f x = descend f x---descendAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_-descendAppsM f (App s x y) = liftM2 (App s) (descendAppsM f x) (f y)-descendAppsM f x = descendM f x---universeApps :: Exp_ -> [Exp_]-universeApps x = x : concatMap universeApps (childrenApps x)--transformApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_-transformApps f = f . descendApps (transformApps f)--transformAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_-transformAppsM f x = f =<< descendAppsM (transformAppsM f) x--------------------------------------------------------------------------- UNIPLATE FUNCTIONS--universeS :: (Data x, Data (f S)) => x -> [f S]-universeS = universeBi--childrenS :: (Data x, Data (f S)) => x -> [f S]-childrenS = childrenBi----- return the parent along with the child-universeParentExp :: Data a => a -> [(Maybe (Int, Exp_), Exp_)]-universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs]-    where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p]--------------------------------------------------------------------------- SRCLOC FUNCTIONS--showSrcLoc :: SrcLoc -> String-showSrcLoc (SrcLoc file line col) = take 1 file ++ f (drop 1 file) ++ ":" ++ show line ++ ":" ++ show col-    where f (x:y:zs) | isPathSeparator x && isPathSeparator y = f $ x:zs-          f (x:xs) = x : f xs-          f [] = []--an :: SrcSpanInfo-an = def--dropAnn :: Functor f => f SrcSpanInfo -> f ()-dropAnn = void-------------------------------------------------------------------------- SRCLOC EQUALITY---- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor--x /=~= y = not $ x =~= y--elem_, notElem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool-elem_ x = any (x =~=)-notElem_ x = not . elem_ x--nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S]-nub_ = nubBy (=~=)--delete_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> [f S]-delete_ = deleteBy (=~=)--intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S]-intersect_ = intersectBy (=~=)--eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool-neqList x y = not $ eqList x y-eqList (x:xs) (y:ys) = x =~= y && eqList xs ys-eqList [] [] = True-eqList _ _ = False--eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool-eqMaybe (Just x) (Just y) = x =~= y-eqMaybe Nothing Nothing = True-eqMaybe _ _ = False--------------------------------------------------------------------------- FIXITIES--getFixity :: Decl a -> [Fixity]-getFixity (InfixDecl sl a mp ops) = [Fixity (void a) (fromMaybe 9 mp) (UnQual () $ void $ f op) | op <- ops]-    where f (VarOp _ x) = x-          f (ConOp _ x) = x-getFixity _ = []--toInfixDecl :: Fixity -> Decl ()-toInfixDecl (Fixity a b c) = InfixDecl () a (Just b) $ maybeToList $ VarOp () <$> fromQual c------ | This extension implies the following extensions-extensionImplies :: Extension -> [Extension]-extensionImplies = \x -> Map.findWithDefault [] x mp-    where mp = Map.fromList extensionImplications---- | This extension is implied by the following extensions-extensionImpliedBy :: Extension -> [Extension]-extensionImpliedBy = \x -> Map.findWithDefault [] x mp-    where mp = Map.fromListWith (++) [(b, [a]) | (a,bs) <- extensionImplications, b <- bs]---- | (a, bs) means extension a implies all of bs.---   Taken from https://downloads.haskell.org/~ghc/master/users-guide/glasgow_exts.html#language-options---   In the GHC source at DynFlags.impliedXFlags-extensionImplications :: [(Extension, [Extension])]-extensionImplications = map (first EnableExtension) $-    (RebindableSyntax, [DisableExtension ImplicitPrelude]) :-    map (second (map EnableExtension))-    [ (DerivingVia              , [DerivingStrategies])-    , (RecordWildCards          , [DisambiguateRecordFields])-    , (ExistentialQuantification, [ExplicitForAll])-    , (FlexibleInstances        , [TypeSynonymInstances])-    , (FunctionalDependencies   , [MultiParamTypeClasses])-    , (GADTs                    , [MonoLocalBinds])-    , (IncoherentInstances      , [OverlappingInstances])---    Incorrect, see https://github.com/ndmitchell/hlint/issues/587---    , (ImplicitParams           , [FlexibleContexts, FlexibleInstances])-    , (ImpredicativeTypes       , [ExplicitForAll, RankNTypes])-    , (LiberalTypeSynonyms      , [ExplicitForAll])-    , (PolyKinds                , [KindSignatures])-    , (RankNTypes               , [ExplicitForAll])-    , (ScopedTypeVariables      , [ExplicitForAll])-    , (TypeOperators            , [ExplicitNamespaces])-    , (TypeFamilies             , [ExplicitNamespaces, KindSignatures, MonoLocalBinds])-    , (TypeFamilyDependencies   , [ExplicitNamespaces, KindSignatures, MonoLocalBinds, TypeFamilies])-    ]

@@ -1,6 +1,6 @@  module Hint.All(-    Hint(..), DeclHint, ModuHint,+    Hint(..), ModuHint,     resolveHints, hintRules, builtinHints     ) where @@ -44,41 +44,38 @@  builtin :: HintBuiltin -> Hint builtin x = case x of-    -- Hse.-    HintLambda     -> decl lambdaHint-     -- Ghc.+    HintLambda     -> decl lambdaHint     HintImport     -> modu importHint     HintExport     -> modu exportHint     HintComment    -> modu commentHint     HintPragma     -> modu pragmaHint     HintDuplicate  -> mods duplicateHint     HintRestrict   -> mempty{hintModule=restrictHint}-    HintList       -> decl' listHint-    HintNewType    -> decl' newtypeHint-    HintUnsafe     -> decl' unsafeHint-    HintListRec    -> decl' listRecHint-    HintNaming     -> decl' namingHint-    HintBracket    -> decl' bracketHint-    HintSmell      -> mempty{hintDecl'=smellHint,hintModule=smellModuleHint}-    HintPattern    -> decl' patternHint-    HintMonad      -> decl' monadHint+    HintList       -> decl listHint+    HintNewType    -> decl newtypeHint+    HintUnsafe     -> decl unsafeHint+    HintListRec    -> decl listRecHint+    HintNaming     -> decl namingHint+    HintBracket    -> decl bracketHint+    HintSmell      -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}+    HintPattern    -> decl patternHint+    HintMonad      -> decl monadHint     HintExtensions -> modu extensionsHint     where         wrap = timed "Hint" (drop 4 $ show x) . forceList         decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}-        decl' f = mempty{hintDecl'=const $ \a b c -> wrap $ f a b c}         modu f = mempty{hintModule=const $ \a b -> wrap $ f a b}         mods f = mempty{hintModules=const $ \a -> wrap $ f a}  -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)]-builtinHints = [(drop 4 $ show h, builtin h) | h <- [minBound .. maxBound]]+builtinHints = [(drop 4 $ show h, builtin h) | h <- enumerate]  -- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'. resolveHints :: [Either HintBuiltin HintRule] -> Hint resolveHints xs =-  mconcat $ mempty{hintDecl'=const $ readMatch' rights} : map builtin (nubOrd lefts)+  mconcat $ mempty{hintDecl=const $ readMatch' rights} : map builtin (nubOrd lefts)   where (lefts,rights) = partitionEithers xs  -- | Transform a list of 'HintRule' into a 'Hint'.

@@ -35,6 +35,11 @@ yes = (($1)) -- @Warning ($1) no = (+5) yes = ((+5)) -- @Warning (+5)+issue909 = case 0 of { _ | n <- (0 :: Int) -> n }+issue909 = foo (\((x :: z) -> y) -> 9 + x * 7)+issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7+issue909 = let ((x:: y) -> z) = q in q+issue909 = do {((x :: y) -> z) <- e; return 1}  -- type bracket reduction foo :: (Int -> Int) -> Int@@ -51,11 +56,12 @@  -- dollar reduction tests no = groupFsts . sortFst $ mr-yes = split "to" $ names -- split "to" names-yes = white $ keysymbol -- white keysymbol-yes = operator foo $ operator -- operator foo operator+yes = split "to" $ names --+yes = white $ keysymbol --+yes = operator foo $ operator -- no = operator foo $ operator bar yes = return $ Record{a=b}+no = f $ [1,2..5] -- @NoRefactor: apply-refact bug; see apply-refact #51  -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e@@ -68,7 +74,7 @@ main = do a += b . c; return $ a . b  -- <$> bracket tests-yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q+yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q @NoRefactor: refactoring for "(v1 . v2) <$> v3" is not implemented no = foo . bar x <$> baz q  -- annotations@@ -89,12 +95,13 @@  module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',Severity(..),toSS')+import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',suggestRemove,Severity(..),toSS') import Data.Data+import Data.List.Extra import Data.Generics.Uniplate.Operations import Refact.Types -import HsSyn+import GHC.Hs import Outputable import SrcLoc import GHC.Util@@ -104,13 +111,13 @@ bracketHint _ _ 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 (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LPat 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+       L l (HsPar _ x) -> x        x -> x  -- If we find ourselves in the context of a section and we want to@@ -120,8 +127,8 @@ -- 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 s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs) prettyExpr x = unsafePrettyPrint x  -- Dirty, should add to Brackets type class I think@@ -144,8 +151,8 @@  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 (L _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True+isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True isPartialAtom x = isRecConstr x || isRecUpdate x  bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea]@@ -183,7 +190,7 @@     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]+    g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o]  bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea bracketWarning msg o x =@@ -194,8 +201,8 @@   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+fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) =+   let r = L 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))@@ -206,10 +213,9 @@      -- 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_fld (L _ 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 #-}'+     ppr_fld (L _ (XConDeclField x)) = ppr x       ppr_names [n] = ppr n      ppr_names ns = sep (punctuate comma (map ppr ns))@@ -220,26 +226,26 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe   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+    f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d+            , let y = noLoc (HsApp noExtField 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+            |(t, e@(L _ (HsPar _ (L _ (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 y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField 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]+          | L _ (OpApp _ (L _ (HsPar _ o1@(L _ (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>"+          , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs]  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 (L l (OpApp _ lhs op rhs)) =+  [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)] splitInfix _ = []

@@ -38,7 +38,7 @@                where                  isMultiline = isCommentMultiline comm                  s = commentText comm-                 name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s+                 name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s         chk _ = []          grab :: String -> Located AnnotationComment -> String -> Idea@@ -46,4 +46,4 @@           let s1 = commentText o in           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)]+                  refact = [ModifyComment (toRefactSrcSpan' pos) (f s2)]

@@ -7,22 +7,22 @@  <TEST> main = do a; a; a; a-main = do a; a; a; a; a; a -- ???-main = do a; a; a; a; a; a; a -- ???-main = do (do b; a; a; a); do (do c; a; a; a) -- ???-main = do a; a; a; b; a; a; a -- ???+main = do a; a; a; a; a; a -- ??? @NoRefactor: refactoring not supported for duplication hints.+main = do a; a; a; a; a; a; a -- ??? @NoRefactor+main = do (do b; a; a; a); do (do c; a; a; a) -- ??? @NoRefactor+main = do a; a; a; b; a; a; a -- ??? @NoRefactor main = do a; a; a; b; a; a-foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ???-{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ???-{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ???-{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ???+foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ??? @NoRefactor+{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor+{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor+{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor </TEST> -}   module Hint.Duplicate(duplicateHint) where -import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning),showSrcLoc,ghcSrcLocToHSE)+import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning)) import Data.Data import Data.Generics.Uniplate.Operations import Data.Default@@ -32,7 +32,7 @@ import qualified Data.Map as Map  import SrcLoc-import HsSyn+import GHC.Hs import Outputable import Bag import GHC.Util@@ -43,7 +43,7 @@    -- Do expressions.    dupes [ (m, d, y)          | (m, d, x) <- ds-         , HsDo _ _ (LL _ y) :: HsExpr GhcPs <- universeBi x+         , HsDo _ _ (L _ y) :: HsExpr GhcPs <- universeBi x          ] ++   -- Bindings in a 'let' expression or a 'where' clause.    dupes [ (m, d, y)@@ -53,7 +53,7 @@          ]     where       ds = [(modName m, fromMaybe "" (declName d), unLoc d)-           | ModuleEx _ _ m _ <- map snd ms+           | ModuleEx m _ <- map snd ms            , d <- hsmodDecls (unLoc m)]  dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea]@@ -62,8 +62,8 @@         (if length xs >= 5 then Hint.Type.Warning else Suggestion)         "Reduce duplication" p1         (unlines $ map unsafePrettyPrint xs)-        (Just $ "Combine with " ++-         showSrcLoc (ghcSrcLocToHSE (srcSpanStart p2))) []+        (Just $ "Combine with " ++ showSrcSpan' p2)+        []      ){ideaModule = [m1, m2], ideaDecl = [d1, d2]}     | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys]     where

@@ -3,10 +3,10 @@  <TEST> main = 1-module Foo where foo = 1 -- module Foo(module Foo) where+module Foo where foo = 1 -- module Foo(module Foo) where @NoRefactor module Foo(foo) where foo = 1-module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where-module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where+module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where @NoRefactor+module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where @NoRefactor </TEST> -} {-# LANGUAGE TypeFamilies #-}@@ -15,33 +15,33 @@  import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore',Note(..)) -import HsSyn+import GHC.Hs import Module import SrcLoc import OccName import RdrName  exportHint :: ModuHint-exportHint _ (ModuleEx _ _ (LL s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)+exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)   | Nothing <- exports =-      let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExt name)] )} in+      let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in       [(ignore' "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]   | Just (L _ xs) <- exports   , mods <- [x | x <- xs, isMod x]   , modName <- moduleNameString (unLoc name)-  , names <- [ moduleNameString (unLoc n) | (LL _ (IEModuleContents _ n)) <- mods]+  , names <- [ moduleNameString (unLoc n) | (L _ (IEModuleContents _ n)) <- mods]   , exports' <- [x | x <- xs, not (matchesModName modName x)]   , modName `elem` names =       let dots = mkRdrUnqual (mkVarOcc " ... ")-          r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExt (noLoc (IEName (noLoc dots)))) : exports') )}+          r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )}       in         [ignore' "Use explicit module export list" (L s o) (noLoc r) []]       where           o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }-          isMod (LL _ (IEModuleContents _ _)) = True+          isMod (L _ (IEModuleContents _ _)) = True           isMod _ = False -          matchesModName m (LL _ (IEModuleContents _ (L _ n))) = moduleNameString n == m+          matchesModName m (L _ (IEModuleContents _ (L _ n))) = moduleNameString n == m           matchesModName _ _ = False  exportHint _ _ = []

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase, NamedFieldPuns #-}  {-     Suggest removal of unnecessary extensions@@ -33,6 +33,33 @@ foo x = let !y = x in y {-# LANGUAGE BangPatterns #-} \ data Foo = Foo !Int --+{-# LANGUAGE TypeOperators #-} \+data (<+>) a b = Foo a b+{-# LANGUAGE TypeOperators #-} \+data Foo a b = a :+ b --+{-# LANGUAGE TypeOperators #-} \+type (<+>) a b = Foo a b+{-# LANGUAGE TypeOperators #-} \+type Foo a b = a :+ b+{-# LANGUAGE TypeOperators, TypeFamilies #-} \+type family Foo a b :: Type where Foo a b = a :+ b+{-# LANGUAGE TypeOperators, TypeFamilies #-} \+type family Foo a b :: Type where Foo a b = (<+>) a b -- {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators, TypeFamilies #-} \+class Foo a where data (<+>) a+{-# LANGUAGE TypeOperators, TypeFamilies #-} \+class Foo a where foo :: a -> Int <+> Bool+{-# LANGUAGE TypeOperators #-} \+class (<+>) a where+{-# LANGUAGE TypeOperators #-} \+foo :: Int -> Double <+> Bool \+foo x = y+{-# LANGUAGE TypeOperators #-} \+foo :: Int -> (<+>) Double Bool \+foo x = y --+{-# LANGUAGE TypeOperators #-} \+(<+>) :: Int -> Int -> Int \+x <+> y = x + y -- {-# LANGUAGE RecordWildCards #-} \ record field = Record{..} {-# LANGUAGE RecordWildCards #-} \@@ -78,6 +105,13 @@ f x = case x of (# a, b #) -> a {-# LANGUAGE GeneralizedNewtypeDeriving,UnboxedTuples #-} \ newtype T m a = T (m a) deriving (PrimMonad)+{-# LANGUAGE InstanceSigs #-} \+instance Eq a => Eq (T a) where \+  (==) :: T a -> T a -> Bool \+  (==) (T x) (T y) = x==y+{-# LANGUAGE InstanceSigs #-} \+instance Eq a => Eq (T a) where \+  (==) (T x) (T y) = x==y -- {-# LANGUAGE DefaultSignatures #-} \ class Val a where; val :: a -- {-# LANGUAGE DefaultSignatures #-} \@@ -135,33 +169,64 @@ data Set (cxt :: * -> *) a = Set [a] -- @Note Extension KindSignatures is implied by PolyKinds {-# LANGUAGE QuasiQuotes, OverloadedStrings #-} \ main = putStrLn [f|{T.intercalate "blah" []}|]+{-# LANGUAGE NamedFieldPuns #-} \+foo = x{bar}+{-# LANGUAGE PatternSynonyms #-} \+module Foo (pattern Bar) where x = 42+{-# LANGUAGE PatternSynonyms #-} \+import Foo (pattern Bar); x = 42+{-# LANGUAGE PatternSynonyms #-} \+pattern Foo s <- Bar s _ where Foo s = Bar s s+{-# LANGUAGE PatternSynonyms #-} \+x = 42 --+{-# LANGUAGE MultiWayIf #-} \+x = if | b1 -> v1 | b2 -> v2 | otherwise -> v3+{-# LANGUAGE MultiWayIf #-} \+x = if b1 then v1 else if b2 then v2 else v3 --+static = 42+{-# LANGUAGE NamedFieldPuns #-} \+foo Foo{x} = x+{-# LANGUAGE NamedFieldPuns #-} \+foo = Foo{x}+{-# LANGUAGE NamedFieldPuns #-} \+foo = bar{x}+{-# LANGUAGE NamedFieldPuns #-} --+{-# LANGUAGE StaticPointers #-} \+static = 42 -- </TEST> -}   module Hint.Extensions(extensionsHint) where -import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule,extensionImpliedBy,extensionImplies)-import Language.Haskell.Exts.Extension+import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule)+import Extension  import Data.Generics.Uniplate.Operations import Control.Monad.Extra+import Data.Char import Data.List.Extra-import Data.Ratio import Data.Data import Refact.Types import qualified Data.Set as Set import qualified Data.Map as Map  import SrcLoc-import HsSyn+import GHC.Hs import BasicTypes import Class import RdrName import OccName import ForeignCall+ import GHC.Util+import GHC.LanguageExtensions.Type++import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.Types+import Language.Haskell.GhclibParserEx.GHC.Hs.Decls+import Language.Haskell.GhclibParserEx.GHC.Driver.Session  extensionsHint :: ModuHint extensionsHint _ x =@@ -169,21 +234,37 @@         sl         (comment (mkLangExts sl exts))         (Just newPragma)-        ( [RequiresExtension $ prettyExtension gone | x <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++-            [ Note $ "Extension " ++ prettyExtension x ++ " is " ++ reason x+        ( [RequiresExtension (show gone) | x <- before \\ after, gone <- Map.findWithDefault [] x disappear] +++            [ Note $ "Extension " ++ show x ++ " is " ++ reason x             | x <- explainedRemovals])         [ModifyComment (toSS' (mkLangExts sl exts)) newPragma]-    | (LL sl _,  exts) <- langExts $ pragmas (ghcAnnotations x)-    , let before = map parseExtension exts+    | (L sl _,  exts) <- langExts $ pragmas (ghcAnnotations x)+    , let before = map lookupExt (filterEnabled exts)     , let after = filter (`Set.member` keep) before     , before /= after     , let explainedRemovals             | null after && not (any (`Map.member` implied) before) = []             | otherwise = before \\ after     , let newPragma =-            if null after then "" else comment (mkLangExts sl $ map prettyExtension after)+            if null after then "" else comment (mkLangExts sl $ map show after)     ]   where+    filterEnabled :: [String] -> [String]+    filterEnabled  = filter (not . isPrefixOf "No")++    lookupExt :: String -> Extension+    lookupExt s = case readExtension s of+        Just ext -> ext+        Nothing ->+          -- Validity checking of extensions happens when the parse+          -- tree is constructed (via 'getOptions' called from+          -- 'parsePragmasIntoDynFlags'). If an invalid extension is+          -- encountered, it results in a parse error (see+          -- tests/ignore-parse-error3.hs in+          -- 'tests/parse-error.test'). Thus we are assured that the+          -- argument 's' must be in 'xFlags' and this case impossible.+          error ("IMPOSSIBLE: Unrecognized language extension '" ++ s ++ "'")+     usedTH :: Bool     usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x)       -- If TH or QuasiQuotes is on, can use all other extensions@@ -191,9 +272,10 @@      -- All the extensions defined to be used.     extensions :: Set.Set Extension-    extensions = Set.fromList [ parseExtension e-                              | let exts = concatMap snd $ langExts (pragmas (ghcAnnotations x))+    extensions = Set.fromList $ [ lookupExt e+                              | let exts = concatMap (filterEnabled . snd) $ langExts (pragmas (ghcAnnotations x))                               , e <- exts ]+     -- Those extensions we detect to be useful.     useful :: Set.Set Extension     useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions@@ -203,25 +285,27 @@     implied = Map.fromList         [ (e, a)         | e <- Set.toList useful-        , a:_ <- [filter (`Set.member` useful) $ extensionImpliedBy e]]+        , a:_ <- [filter (`Set.member` useful) $ extensionImpliedEnabledBy e]+        ]     -- Those we should keep.     keep :: Set.Set Extension     keep =  useful `Set.difference` Map.keysSet implied     -- The meaning of (a,b) is a used to imply b, but has gone, so     -- suggest enabling b.+    disappear :: Map.Map Extension [Extension]     disappear =         Map.fromListWith (++) $         nubOrdOn snd -- Only keep one instance for each of a.         [ (e, [a])         | e <- Set.toList $ extensions `Set.difference` keep-        , a <- extensionImplies e+        , a <- fst $ extensionImplies e         , a `Set.notMember` useful         , usedTH || usedExt a (ghcModule x)         ]     reason :: Extension -> String     reason x =       case Map.lookup x implied of-        Just a -> "implied by " ++ prettyExtension a+        Just a -> "implied by " ++ show a         Nothing -> "not used"  deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"]@@ -238,13 +322,14 @@ deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory  usedExt :: Extension -> Located (HsModule GhcPs) -> Bool-usedExt (EnableExtension x) = used x-usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac-usedExt (UnknownExtension "DeriveLift") = hasDerive ["Lift"]-usedExt (UnknownExtension "DeriveAnyClass") = not . null . derivesAnyclass . derives-usedExt _ = const True+usedExt NumDecimals = hasS isWholeFrac+  -- Only whole number fractions are permitted by NumDecimals+  -- extension.  Anything not-whole raises an error.+usedExt DeriveLift = hasDerive ["Lift"]+usedExt DeriveAnyClass = not . null . derivesAnyclass . derives+usedExt x = used x -used :: KnownExtension -> Located (HsModule GhcPs) -> Bool+used :: Extension -> Located (HsModule GhcPs) -> Bool used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep (Located RdrName))@@ -258,15 +343,11 @@ used EmptyCase = hasS f   where     f :: HsExpr GhcPs -> Bool-    f (HsCase _ _ (MG _ (LL _ []) _)) = True-    f (HsLamCase _ (MG _ (LL _ []) _)) = True+    f (HsCase _ _ (MG _ (L _ []) _)) = True+    f (HsLamCase _ (MG _ (L _ []) _)) = True     f _ = False used KindSignatures = hasT (un :: HsKind GhcPs)-used BangPatterns = hasS isPBangPat' ||^ hasS isStrictMatch-  where-    isStrictMatch :: HsMatchContext RdrName -> Bool-    isStrictMatch FunRhs{mc_strictness=SrcStrict} = True-    isStrictMatch _ = False+used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl     where       f :: HsBracket GhcPs -> Bool@@ -278,17 +359,33 @@   where     f :: GRHS GhcPs (LHsExpr GhcPs) -> Bool     f (GRHS _ xs _) = g xs-    f _ = False -- new ctor+    f _ = False -- Extension constructor     g :: [GuardLStmt GhcPs] -> Bool     g [] = False-    g [LL _ BodyStmt{}] = False+    g [L _ BodyStmt{}] = False     g _ = True-used StandaloneDeriving = hasS isDerivD'-used PatternSignatures = hasS isPatTypeSig'-used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot'-used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun-used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun-used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed) ||^ hasS isDeriving+used StandaloneDeriving = hasS isDerivD+used TypeOperators = hasS tyOpInSig ||^ hasS tyOpInDecl+  where+    tyOpInSig :: HsType GhcPs -> Bool+    tyOpInSig = \case+      HsOpTy{} -> True; _ -> False++    tyOpInDecl :: HsDecl GhcPs -> Bool+    tyOpInDecl = \case+      (TyClD _ (FamDecl _ FamilyDecl{fdLName})) -> isOp fdLName+      (TyClD _ SynDecl{tcdLName}) -> isOp tcdLName+      (TyClD _ DataDecl{tcdLName}) -> isOp tcdLName+      (TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs])+      _ -> False++    isOp :: LIdP GhcPs -> Bool+    isOp name = case occNameString (rdrNameOcc (unLoc name)) of+      (c:_) -> not $ isAlpha c || c == '_'+      _ -> False+used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot+used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate+used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving     where         -- detect if there are deriving declarations or data ... deriving stuff         -- by looking for the deriving strategy both contain (even if its Nothing)@@ -300,37 +397,41 @@         f :: ImportDecl GhcPs -> Bool         f ImportDecl{ideclPkgQual=Just _} = True         f _ = False-used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote'-used ViewPatterns = hasS isPViewPat'-used DefaultSignatures = hasS isClsDefSig'+used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote+used ViewPatterns = hasS isPViewPat+used InstanceSigs = hasS f+  where+    f :: HsDecl GhcPs -> Bool+    f (InstD _ decl) = hasT (un :: Sig GhcPs) decl+    f _ = False+used DefaultSignatures = hasS isClsDefSig used DeriveDataTypeable = hasDerive ["Data","Typeable"] used DeriveFunctor = hasDerive ["Functor"] used DeriveFoldable = hasDerive ["Foldable"] used DeriveTraversable = hasDerive ["Traversable","Foldable","Functor"] used DeriveGeneric = hasDerive ["Generic","Generic1"] used GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives+used MultiWayIf = hasS isMultiIf used LambdaCase = hasS isLCase used TupleSections = hasS isTupleSection used OverloadedStrings = hasS isString-used Arrows = hasS f-  where-    f :: HsExpr GhcPs -> Bool-    f HsProc{} = True-    f HsArrApp{} = True-    f _ = False-used TransformListComp = hasS f-    where-      f :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool-      f TransStmt{} = True-      f _ = False+used Arrows = hasS isProc+used TransformListComp = hasS isTransStmt used MagicHash = hasS f ||^ hasS isPrimLiteral     where       f :: RdrName -> Bool       f s = "#" `isSuffixOf` (occNameString . rdrNameOcc) s--- For forwards compatibility, if things ever get added to the--- extension enumeration.-used x = usedExt $ UnknownExtension $ show x+used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE+    where+      isPatSynBind :: HsBind GhcPs -> Bool+      isPatSynBind PatSynBind{} = True+      isPatSynBind _ = False +      isPatSynIE :: IEWrappedName RdrName -> Bool+      isPatSynIE IEPattern{} = True+      isPatSynIE _ = False+used _= const True+ hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool hasDerive want = any (`elem` want) . derivesStock' . derives @@ -357,38 +458,35 @@ addDerives nt _ xs = mempty     {derivesStock' = stock     ,derivesAnyclass = other-    ,derivesNewtype' = if maybe True isNewType' nt then filter (`notElem` noDeriveNewtype) xs else []}+    ,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []}     where (stock, other) = partition (`elem` deriveStock) xs  derives :: Located (HsModule GhcPs) -> Derives-derives (LL _ m) =  mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)+derives (L _ m) =  mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)   where     idecl :: Located (DataFamInstDecl GhcPs) -> Derives-    idecl (LL _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(LL _ ds)}}))) = g dn ds+    idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds     idecl _ = mempty      decl :: LHsDecl GhcPs -> Derives-    decl (LL _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(LL _ ds)}))) = g dn ds -- Data declaration.-    decl (LL _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration.+    decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration.+    decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration.     decl _ = mempty      g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives-    g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | LL _ (HsDerivingClause _ strategy (LL _ tys)) <- ds]+    g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds]      derivedToStr :: LHsSigType GhcPs -> String     derivedToStr (HsIB _ t) = ih t       where         ih :: LHsType GhcPs -> String-        ih (LL _ (HsQualTy _ _ a)) = ih a-        ih (LL _ (HsParTy _ a)) = ih a-        ih (LL _ (HsAppTy _ a _)) = ih a-        ih (LL _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual' a-        ih (LL _ a) = unsafePrettyPrint a -- I don't anticipate this case is called.-        ih _ = "" -- {-# COMPLETE LL #-}+        ih (L _ (HsQualTy _ _ a)) = ih a+        ih (L _ (HsParTy _ a)) = ih a+        ih (L _ (HsAppTy _ a _)) = ih a+        ih (L _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual' a+        ih (L _ a) = unsafePrettyPrint a -- I don't anticipate this case is called.     derivedToStr _ = "" -- new ctor -derives _ = mempty -- {-# COMPLETE LL #-}- un = undefined  hasT t x = not $ null (universeBi x `asTypeOf` [t])@@ -396,12 +494,3 @@  hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi--has f = any f . universeBi---- Only whole number fractions are permitted by NumDecimals extension.--- Anything not-whole raises an error.-isWholeFrac :: HsExpr GhcPs -> Bool-isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1-isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1-isWholeFrac _ = False

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-}+{-# LANGUAGE PatternGuards, RecordWildCards #-} {-     Reduce the number of import declarations.     Two import declarations can be combined if:@@ -28,11 +28,11 @@ import qualified A; import A import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar)-import List -- import Data.List-import qualified List -- import qualified Data.List as List-import Char(foo) -- import Data.Char(foo)+import List -- import Data.List @NoRefactor: apply-refact bug+import qualified List -- import qualified Data.List as List @NoRefactor+import Char(foo) -- import Data.Char(foo) @NoRefactor import IO(foo)-import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception  as X (bracket,bracket_)+import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception  as X (bracket,bracket_) @NoRefactor </TEST> -} @@ -53,7 +53,7 @@ import BasicTypes import RdrName import Module-import HsSyn+import GHC.Hs import SrcLoc import GHC.Util @@ -97,7 +97,7 @@ combine :: LImportDecl GhcPs         -> LImportDecl GhcPs         -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])-combine x@(LL _ x') y@(LL _ y')+combine x@(L _ x') y@(L _ y')   -- Both (un/)qualified, common 'as', same names : Delete the second.   | qual, as, specs = Just (x, [Delete Import (toSS' y)])     -- Both (un/)qualified, common 'as', different names : Merge the@@ -115,7 +115,7 @@        in Just (newImp, [Delete Import (toSS' toDelete)])   -- Both unqualified, same names, one (and only one) has an 'as'   -- clause : Delete the one without an 'as'.-  | not (ideclQualified x'), qual, specs, length ass == 1 =+  | ideclQualified x' == NotQualified, qual, specs, length ass == 1 =        let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)        in Just (newImp, [Delete Import (toSS' toDelete)])   -- No hints.@@ -131,17 +131,16 @@         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@(LL loc i@ImportDecl {..})+stripRedundantAlias x@(L loc i@ImportDecl {..})   -- Suggest 'import M as M' be just 'import M'.   | 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@(LL loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing})+preferHierarchicalImports x@(L 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) =@@ -162,11 +161,11 @@     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 noExtField (noLoc (IEName (noLoc (mkVarUnqual (fsLit n)))))     -- Rewrite 'import qualified X' as 'import qualified X as X'.     desugarQual :: ImportDecl GhcPs -> ImportDecl GhcPs     desugarQual i-      | ideclQualified i && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}+      | ideclQualified i /= NotQualified && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}       | otherwise = i  preferHierarchicalImports _ = []

@@ -22,37 +22,39 @@ <TEST> f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a+f (Just a) = \a -> a + a -- f (Just _) a = a + a @NoRefactor f a = \x -> x + x where _ = test f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x-fun x y z = f x y z -- fun = f-fun x y z = f x x y z -- fun x = f x x-fun x y z = f g z -- fun x y = f g-fun mr = y mr-fun x = f . g $ x -- fun = f . g+fun x y z = f x y z -- fun = f @NoRefactor: refactoring for eta reduce is not implemented+fun x y z = f x x y z -- fun x = f x x @NoRefactor+fun x y z = f g z -- fun x y = f g @NoRefactor+fun x = f . g $ x -- fun = f . g @NoRefactor f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda-f = foo ((*) x) -- (x *)+f = foo ((*) x) -- (x *) @NoRefactor f = (*) x-f = foo (flip op x) -- (`op` x)-f = foo (flip op x) -- @Message Use section+f = foo (flip op x) -- (`op` x) @NoRefactor+f = foo (flip op x) -- @Message Use section @NoRefactor foo x = bar (\ d -> search d table) -- (`search` table) foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix` f = flip op x-f = foo (flip (*) x) -- (* x)+f = foo (flip (*) x) -- (* x) @NoRefactor f = foo (flip (-) x) f = foo (\x y -> fun x y) -- @Warning fun+f = foo (\x y z -> fun x y z) -- @Warning fun+f = foo (\z -> f x $ z) -- f x f = foo (\x y -> x + y) -- (+) f = foo (\x -> x * y) -- @Suggestion (* y) f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(foo -> x) -> \y -> x x y y)-f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x+f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x @NoRefactor f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i)-f = bar (flip Foo.bar x) -- (`Foo.bar` x)+f = bar (flip Foo.bar x) -- (`Foo.bar` x) @NoRefactor f = a b (\x -> c x d)  -- (`c` d) yes = \x -> a x where -- a yes = \x y -> op y x where -- flip op@@ -65,18 +67,24 @@ foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m]-foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux)+foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) @NoRefactor foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f-baz = bar (\x -> (x +)) -- (+)-foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z-yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b+foo = bar (\x -> shakeRoot </> "src" </> x)+baz = bar (\x -> (x +)) -- (+) @NoRefactor+xs `withArgsFrom` args = f args+foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z @NoRefactor+yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b @NoRefactor+yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file @NoRefactor no = blah (\ x -> case x of A -> a x; B -> b x)-yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)+yes = blah (\ x -> (y, x)) -- (y,) @NoRefactor+yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) @NoRefactor+yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @NoRefactor+yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST $ action x)-yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>)+yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>) @NoRefactor {-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a]) {-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name {-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name)@@ -86,96 +94,178 @@  module Hint.Lambda(lambdaHint) where -import Hint.Util-import Hint.Type+import Hint.Type (DeclHint', Idea, Note(RequiresExtension), suggest', warn', toSS', suggestN', ideaNote) import Util import Data.List.Extra-import Data.Maybe import qualified Data.Set as Set import Refact.Types hiding (RType(Match))+import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi) +import BasicTypes+import GHC.Util.Brackets (isAtom')+import GHC.Util.FreeVars (free', allVars', freeVars', pvars', vars', varss')+import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR', lambda)+import GHC.Util.Outputable+import GHC.Util.RdrName (rdrNameStr')+import GHC.Util.View+import GHC.Hs+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)+import OccName+import RdrName+import SrcLoc -lambdaHint :: DeclHint-lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x)+lambdaHint :: DeclHint'+lambdaHint _ _ x+    =  concatMap (uncurry lambdaExp) (universeParentBi x)+    ++ concatMap lambdaDecl (universe x) +lambdaDecl :: LHsDecl GhcPs -> [Idea]+lambdaDecl+    o@(L _ (ValD _+        origBind@FunBind {fun_id = L loc1 _, fun_matches =+            MG {mg_alts =+                L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))+    | L _ (EmptyLocalBinds noExtField) <- bind+    , isLambda $ fromParen' origBody+    , null (universeBi pats :: [HsExpr GhcPs])+    = [warn' "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS' o) s1 t1]]+    | length pats2 < length pats, pvars' (drop (length pats2) pats) `disjoint` varss' bind+    = [warn' "Eta reduce" (reform pats origBody) (reform pats2 bod2)+          [ -- Disabled, see apply-refact #3+            -- Replace Decl (toSS' $ reform' pats origBody) s2 t2]]+          ]]+    where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs+          reform ps b = L loc $ ValD noExtField $+            origBind+              {fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated} -lambdaDecl :: Decl_ -> [Idea]-lambdaDecl (toFunBind -> o@(FunBind loc1 [Match _ name pats (UnGuardedRhs loc2 bod) bind]))-    | isNothing bind, isLambda $ fromParen bod, null (universeBi pats :: [Exp_]) =-      [warn "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]]-    | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind-        = [warn "Eta reduce" (reform pats bod) (reform pats2 bod2)-            [ -- Disabled, see apply-refact #3-              -- Replace Decl (toSS $ reform pats bod) s2 t2]]-            ]]-        where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing]-              loc = setSpanInfoEnd loc1 $ srcSpanEnd $ srcInfoSpan loc2-              gen ps = uncurry reform . fromLambda . Lambda an ps-              (finalpats, body) = fromLambda . Lambda an pats $ bod-              (pats2, bod2) = etaReduce pats bod-              template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (toNamed "body")-              munge :: Char -> Pat_ -> Pat_-              munge ident p@(PWildCard _) = p-              munge ident p = PVar (ann p) (Ident (ann p) [ident])-              subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)-              s1 = subts finalpats body-              --s2 = subts pats2 bod2-              t1 = template finalpats body-              --t2 = template pats2 bod2+          loc = combineSrcSpans loc1 loc2 -lambdaDecl _ = []+          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs+          gen ps = uncurry reform . fromLambda . lambda ps -setSpanInfoEnd ssi (line, col) = ssi{srcInfoSpan = (srcInfoSpan ssi){srcSpanEndLine=line, srcSpanEndColumn=col}}+          (finalpats, body) = fromLambda . lambda pats $ origBody+          (pats2, bod2) = etaReduce pats origBody+          template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody+          subts fps b = ("body", toSS' b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' fps)+          s1 = subts finalpats body+          --s2 = subts pats2 bod2+          t1 = template finalpats+          --t2 = template pats2 bod2+lambdaDecl _ = []  -etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_)-etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y))))-    | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x+etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)+etaReduce (unsnoc -> Just (ps, view' -> PVar_' p)) (L _ (HsApp _ x (view' -> Var_' y)))+    | p == y+    , y `notElem` vars' x     , not $ any isQuasiQuote $ universe x-    = etaReduce (init ps) x-etaReduce ps (InfixApp a x (isDol -> True) y) = etaReduce ps (App a x y)-etaReduce ps x = (ps,x)-+    = etaReduce ps x+etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y))+etaReduce ps x = (ps, x)  --Section refactoring is not currently implemented.-lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea]-lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, not $ isTypeApp y, allowLeftSection x =-    [suggestN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]]+lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]+lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ (L _ (rdrNameOcc -> f)))) y))))+    | isSymOcc f -- is this an operator?+    , isAtom' y+    , allowLeftSection $ occNameString f+    , not $ isTypeApp y =+      [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper]++lambdaExp _ o@(L _ (HsPar _ (view' -> App2' (view' -> Var_' "flip") origf@(view' -> Var_' f) y)))+    | allowRightSection f+    = [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y]+lambdaExp p o@(L _ HsLam{})+    | not $ any isOpApp p+    , (res, refact) <- niceLambdaR' [] o+    , not $ isLambda res+    , not $ any isQuasiQuote $ universe res+    , not $ "runST" `Set.member` Set.map occNameString (freeVars' o)+    , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")+    = [(if isVar res then warn' else suggest') name o res (refact $ toSS' o)]     where-      exp op rhs = LeftSection an op (toNamed rhs)---      template = prettyPrint (exp (toNamed "a") "*")---      subts = [("a", toSS y), ("*", toSS v)]-lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x =-    [suggestN "Use section" o $ RightSection an (QVarOp an x) y]-lambdaExp p o@Lambda{}-    | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o-    , not $ isLambda res, not $ any isQuasiQuote $ universe res, not $ "runST" `Set.member` freeVars o-    , let name = "Avoid lambda" ++ (if countInfixNames res > countInfixNames o then " using `infix`" else "") =-    [(if isVar res || isCon res then warn else suggest) name o res (refact $ toSS o)]-    where countInfixNames x = length [() | RightSection _ (QVarOp _ (UnQual _ (Ident _ _))) _ <- universe x]-lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p =-    [suggest "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]]+        countRightSections :: LHsExpr GhcPs -> Int+        countRightSections x = length [() | L _ (SectionR _ (view' -> Var_' _) _) <- universe x]+lambdaExp p o@(SimpleLambda origPats origBody)+    | isLambda (fromParen' origBody)+    , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?+    , maybe True (not . isLambda) p =+    [suggest' "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS' o) subts template]]     where       (pats, body) = fromLambda o-      template = prettyPrint $  Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body")-      munge :: Char -> Pat_ -> Pat_-      munge ident p@(PWildCard _) = p-      munge ident p = PVar (ann p) (Ident (ann p) [ident])-      subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)-lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts))-    | u == v, u `notElem` vars alts = case alts of-        [Alt _ pat (UnGuardedRhs _ bod) Nothing] -> [suggestN "Use lambda" o $ Lambda an [pat] bod]-        _ -> [(suggestN "Use lambda-case" o $ LCase an alts){ideaNote=[RequiresExtension "LambdaCase"]}]-lambdaExp p o@(Lambda _ [view -> PVar_ u] (Tuple _ boxed xs))-    | ([yes],no) <- partition (~= u) xs, u `notElem` concatMap vars no-    = [(suggestN "Use tuple-section" o $ TupleSection an boxed [if x ~= u then Nothing else Just x | x <- xs])-        {ideaNote=[RequiresExtension "TupleSections"]}]++      template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody++      subts = ("body", toSS' body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' pats)++-- match a lambda with a variable pattern, with no guards and no where clauses+lambdaExp _ o@(SimpleLambda [view' -> PVar_' x] (L _ expr)) =+    case expr of+        -- suggest TupleSections instead of lambdas+        ExplicitTuple _ args boxity+            -- is there exactly one argument that is exactly x?+            | ([_x], ys) <- partition ((==Just x) . tupArgVar) args+            -- the other arguments must not have a nested x somewhere in them+            , Set.notMember x $ Set.map occNameString $ freeVars' ys+            -> [(suggestN' "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)+                  {ideaNote = [RequiresExtension "TupleSections"]}]++        -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@+        HsCase _ (view' -> Var_' x') matchGroup+            -- is the case being done on the variable from our original lambda?+            | x == x'+            -- x must not be used in some other way inside the matches+            , Set.notMember x $ Set.map occNameString $ free' $ allVars' matchGroup+            -> case matchGroup of+                 -- is there a single match? - suggest match inside the lambda+                 --+                 -- we need to+                 --     * add brackets to the match, because matches in lambdas require them+                 --     * mark match as being in a lambda context so that it's printed properly+                 oldMG@(MG _ (L _ [L _ oldmatch]) _) ->+                     [suggestN' "Use lambda" o $ noLoc $ HsLam noExtField oldMG+                         { mg_alts = noLoc+                             [noLoc oldmatch+                                 { m_pats = map mkParPat $ m_pats oldmatch+                                 , m_ctxt = LambdaExpr+                                 }+                             ] }+                     ]++                 -- otherwise we should use @LambdaCase@+                 MG _ (L _ xs) _ ->+                     [(suggestN' "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)+                         {ideaNote=[RequiresExtension "LambdaCase"]}]+                 _ -> []+        _ -> []+    where+        -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument+        -- to a missing argument, so that we get the proper section.+        removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs+        removeX arg@(L _ (Present _ (view' -> Var_' x')))+            | x == x' = noLoc $ Missing noExtField+        removeX y = y+        -- | Extract the name of an argument of a tuple if it's present and a variable.+        tupArgVar :: LHsTupArg GhcPs -> Maybe String+        tupArgVar (L _ (Present _ (view' -> Var_' x))) = Just x+        tupArgVar _ = Nothing+ lambdaExp _ _ = [] +varBody :: LHsExpr GhcPs+varBody = strToVar "body" --- replace any repeated pattern variable with _-fromLambda :: Exp_ -> ([Pat_], Exp_)-fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)-    where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an+-- | Squash lambdas and replace any repeated pattern variable with @_@+fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)+fromLambda (SimpleLambda ps1 (fromLambda . fromParen' -> (ps2,x))) = (transformBi (f $ pvars' ps2) ps1 ++ ps2, x)+    where f :: [String] -> Pat GhcPs -> Pat GhcPs+          f bad (VarPat _ (rdrNameStr' -> x))+              | x `elem` bad = WildPat noExtField           f bad x = x fromLambda x = ([], x)++-- | Replaces all non-wildcard patterns with a variable pattern with the given identifier.+munge :: Char -> LPat GhcPs -> LPat GhcPs+munge ident p@(L _ (WildPat _)) = p+munge ident (L ploc p) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))

@@ -13,7 +13,7 @@ no = "x" ++ xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys-yes = [if a then b else c] ++ xs -- (if a then b else c) : xs+yes = [if a then b else c] ++ xs -- (if a then b else c) : xs @NoRefactor: hlint bug, missing brackets in refactoring template yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]] yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs data Yes = Yes (Maybe [Char]) -- Maybe String@@ -43,12 +43,12 @@ import Data.Maybe import Prelude -import Hint.Type(DeclHint',Idea,suggest',toSS')+import Hint.Type(DeclHint',Idea,suggest',toRefactSrcSpan',toSS')  import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R -import HsSyn+import GHC.Hs import SrcLoc import BasicTypes import RdrName@@ -58,7 +58,9 @@ import TysWiredIn  import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.Types import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances  listHint :: DeclHint'@@ -75,21 +77,21 @@ -- structure of 'listComp'.  listComp :: LHsExpr GhcPs -> [Idea]-listComp o@(LL _ (HsDo _ ListComp (L _ stmts))) =+listComp o@(L _ (HsDo _ ListComp (L _ stmts))) =   listCompCheckGuards o ListComp stmts-listComp o@(LL _ (HsDo _ MonadComp (L _ stmts))) =+listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) =   listCompCheckGuards o MonadComp stmts -listComp o@(view' -> App2' mp f (LL _ (HsDo _ ListComp (L _ stmts)))) =+listComp o@(view' -> App2' mp f (L _ (HsDo _ ListComp (L _ stmts)))) =   listCompCheckMap o mp f ListComp stmts-listComp o@(view' -> App2' mp f (LL _ (HsDo _ MonadComp (L _ stmts)))) =+listComp o@(view' -> App2' mp f (L _ (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.+      e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last.       xs = reverse (tail revs) in   list_comp_aux e xs   where@@ -100,12 +102,12 @@       | otherwise = []       where         ys = moveGuardsForward xs-        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])+        o' = noLoc $ ExplicitList noExtField Nothing []+        o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e]))+        o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e])         cons = mapMaybe qualCon xs         qualCon :: ExprLStmt GhcPs -> Maybe String-        qualCon (L _ (BodyStmt _ (LL _ (HsVar _ (L _ x))) _ _)) = Just (occNameString . rdrNameOcc $ x)+        qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameString . rdrNameOcc $ x)         qualCon _ = Nothing  listCompCheckMap ::@@ -114,9 +116,9 @@     [suggest' "Move map inside list comprehension" o o2 (suggestExpr o o2)]     where       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])+      L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.+      last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren' f) (paren' body)) b s+      o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last]) listCompCheckMap _ _ _ _ _ = []  suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]@@ -127,16 +129,24 @@   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)+              span (if any hasPFieldsDotDot (universeBi x)+                       || any isPFieldWildcard (universeBi x)                       then const False-                      else \x -> pvars' p `disjoint` vars_ x) guards+                      else \x ->+                       let pvars = pvars' p in+                       -- See this code from 'RdrHsSyn.hs' (8.10.1):+                       --   plus_RDR, pun_RDR :: RdrName+                       --   plus_RDR = mkUnqual varName (fsLit "+") -- Hack+                       --   pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")+                       -- Todo (SF, 2020-03-28): Try to make this better somehow.+                       pvars `disjoint` vars_ x && "pun-right-hand-side" `notElem` pvars+                   ) 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      -- Fake something that works-    vars_ x = [unsafePrettyPrint a | HsVar _ (LL _ a) <- universeBi x :: [HsExpr GhcPs]]+    vars_ x = [unsafePrettyPrint a | HsVar _ (L _ a) <- universeBi x :: [HsExpr GhcPs]]  listExp :: Bool -> LHsExpr GhcPs -> [Idea] listExp b (fromParen' -> x) =@@ -147,7 +157,7 @@           , Just (x2, subts, temp) <- [f b x]           , let r = Replace Expr (toSS' x) subts temp ] -listPat :: Pat GhcPs -> [Idea]+listPat :: LPat 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@@ -158,54 +168,54 @@ isAppend _ = False  checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]-checks = let (*) = (,) in drop 1 -- see #174+checks = let (*) = (,) in drop1 -- see #174   [ "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+pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))]+pchecks = let (*) = (,) in drop1 -- see #174     [ "Use string literal pattern" * usePString     , "Use list literal pattern" * usePList     ] -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)))+usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String)+usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =+  let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s)))   in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing -usePList :: Pat GhcPs -> Maybe (Pat GhcPs, [(String, R.SrcSpan)], String)+usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList =   fmap  ( (\(e, s) ->-             (noLoc (ListPat noExt e)-             , map (fmap toSS') s-             , unsafePrettyPrint (noLoc $ ListPat noExt (map snd s) :: Pat GhcPs))+             (noLoc (ListPat noExtField e)+             , map (fmap toRefactSrcSpan' . fst) s+             , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs))           )           . unzip         )   . f True ['a'..'z']   where-    f first _ x | patToStr' x == "[]" = if first then Nothing else Just []+    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 GhcPs -> (String, Pat GhcPs)-    g c p = ([c], VarPat noExt (noLoc $ mkVarUnqual (fsLit [c])))+    g :: Char -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)+    g c (getLoc -> loc) = (([c], loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit [c])))  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))))+useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs =+  let literal = noLoc (HsLit noExtField (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) ->-             (noLoc (ExplicitList noExt Nothing e)+             (noLoc (ExplicitList noExtField Nothing e)              , map (fmap toSS') s-             , unsafePrettyPrint (noLoc $ ExplicitList noExt Nothing (map snd s) :: LHsExpr GhcPs))+             , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs))           )           . unzip         )@@ -217,7 +227,7 @@     f first _ _ = Nothing      g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)-    g c p = ([c], strToVar [c])+    g c p = ([c], L (getLoc p) (unLoc $ strToVar [c]))  useCons :: View' a App2' => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useCons False (view' -> App2' op x y) | varToStr op == "++"@@ -230,25 +240,25 @@   where     f :: LHsExpr GhcPs ->       Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)-    f (LL _ (ExplicitList _ _ [x]))=+    f (L _ (ExplicitList _ _ [x]))=       Just (x, \v -> if isApp x then v else paren' v)     f _ = Nothing      gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-    gen x = noLoc . OpApp noExt x (noLoc (HsVar noExt  (noLoc consDataCon_RDR)))+    gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField  (noLoc consDataCon_RDR))) useCons _ _ = Nothing  typeListChar :: LHsType GhcPs typeListChar =-  noLoc $ HsListTy noExt-    (noLoc (HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "Char")))))+  noLoc $ HsListTy noExtField+    (noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char")))))  typeString :: LHsType GhcPs typeString =-  noLoc $ HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "String")))+  noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String")))  stringType :: LHsDecl GhcPs  -> [Idea]-stringType (LL _ x) = case x of+stringType (L _ x) = case x of   InstD _ ClsInstD{     cid_inst=         ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->@@ -258,8 +268,7 @@     f x = concatMap g $ childrenBi x      g :: LHsType GhcPs -> [Idea]-    g e@(fromTyParen' -> x) = [suggest' "Use String" x (transform f x)+    g e@(fromTyParen -> x) = [suggest' "Use String" x (transform f x)                               rs | not . null $ rs]       where f x = if astEq x typeListChar then typeString else x             rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]-stringType _ = [] -- {-# COMPLETE LL #-}

@@ -41,18 +41,19 @@ import Refact.Types hiding (RType(Match))  import SrcLoc-import HsExtension-import HsPat-import HsTypes+import GHC.Hs.Extension+import GHC.Hs.Pat+import GHC.Hs.Types import TysWiredIn import RdrName-import HsBinds-import HsExpr-import HsDecls+import GHC.Hs.Binds+import GHC.Hs.Expr+import GHC.Hs.Decls import OccName import BasicTypes  import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances @@ -67,7 +68,7 @@             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)]+            pure $ idea' severity ("Use " ++ use) o y [Replace Decl (toSS' o) [] (unsafePrettyPrint y)]  recursiveStr :: String recursiveStr = "_recursive_"@@ -99,7 +100,7 @@ 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 == ":"+    | [] <- vs, varToStr nil == "[]", (L _ (OpApp _ lhs c rhs)) <- cons, varToStr c == ":"     , astEq (fromParen' rhs) recursive, xs `notElem` vars' lhs     = Just $ (,,) "map" Hint.Type.Warning $       appsBracket' [ strToVar "map", niceLambda' [x] lhs, strToVar xs]@@ -110,14 +111,14 @@     = 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+    | [v] <- vs, view' nil == Var_' v, (L _ (HsApp _ r lhs)) <- cons     , astEq (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+    | [v] <- vs, (L _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view' res == Var_' v+    , [L _ (BindStmt _ (view' -> PVar_' b1) e _ _), L _ (BodyStmt _ (fromParen' -> (L _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons     , b1 == b2, astEq r recursive, xs `notElem` vars' e     , name <- "foldM" ++ ['_' | varToStr res == "()"]     = Just $ (,,) name Suggestion $@@ -130,19 +131,19 @@ asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)] asDo (view' ->        App2' bind lhs-         (LL _ (HsLam _ MG {+         (L _ (HsLam _ MG {               mg_origin=FromSource-            , mg_alts=LL _ [-                 LL _ Match {  m_ctxt=LambdaExpr-                            , m_pats=[LL _ v@VarPat{}]+            , mg_alts=L _ [+                 L _ Match {  m_ctxt=LambdaExpr+                            , m_pats=[v@(L _ VarPat{})]                             , m_grhss=GRHSs _-                                        [LL _ (GRHS _ [] rhs)]-                                        (LL _ (EmptyLocalBinds _))}]}))+                                        [L _ (GRHS _ [] rhs)]+                                        (L _ (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]+  [ noLoc $ BindStmt noExtField v lhs noSyntaxExpr noSyntaxExpr+  , noLoc $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ]+asDo (L _ (HsDo _ DoExpr (L _ stmts))) = stmts+asDo x = [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]   ---------------------------------------------------------------------@@ -152,43 +153,43 @@ findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs) findCase x = do   -- Match a function binding with two alternatives.-  (LL _ (ValD _ FunBind {fun_matches=+  (L _ (ValD _ FunBind {fun_matches=               MG{mg_origin=FromSource, mg_alts=-                     (LL _-                            [ x1@(LL _ Match{..}) -- Match fields.+                     (L _+                            [ x1@(L _ Match{..}) -- Match fields.                             , x2]), ..} -- Match group fields.           , ..} -- Fun. bind fields.-      )) <- return x+      )) <- pure 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)]+  [(BNil, b1), (BCons x xs, b2)] <- pure $ sortOn fst [(c1, b1), (c2, b2)]   b2 <- transformAppsM' (delCons name1 p1 xs) b2-  (ps, b2) <- return $ eliminateArgs ps1 b2+  (ps, b2) <- pure $ 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.+  let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.+      emptyLocalBinds = noLoc $ EmptyLocalBinds noExtField -- Empty where clause.+      gRHS e = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+      gRHSSs e = GRHSs noExtField [gRHS e] emptyLocalBinds -- Guarded rhs set.+      match e = Match{m_ext=noExtField,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. -  return (ListCase ps b1 (x, xs, b2), noLoc . ValD noExt . funBind)+  pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . 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+    (pre, (view' -> Var_' v) : post) <- pure $ splitAt pos xs     guard $ v == var-    return $ apps' $ recursive : pre ++ post-delCons _ _ _ x = return x+    pure $ apps' $ recursive : pre ++ post+delCons _ _ _ x = pure x  eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons)   where     args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq z recursive]-    elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False+    elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zipFrom 0 ps] ++ repeat False     remove = concat . zipWith (\b x -> [x | not b]) elim      f (fromApps' -> x : xs) | astEq x recursive = apps' $ x : remove xs@@ -207,22 +208,22 @@               GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]                         , grhssLocalBinds=L _ (EmptyLocalBinds _)                         }-            } <- return x+            } <- pure x   (a, b, c) <- findPat ps-  return $ Branch (occNameString $rdrNameOcc name) a b c $ simplifyExp' body+  pure $ Branch (occNameString $rdrNameOcc name) a b c $ simplifyExp' body  findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList) findPat ps = do   ps <- mapM readPat ps-  [i] <- return $ findIndices isRight ps+  [i] <- pure $ findIndices isRight ps   let (left, [right]) = partitionEithers ps -  return (left, i, right)+  pure (left, i, right) -readPat :: Pat GhcPs -> Maybe (Either String BList)+readPat :: LPat 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))))))+readPat (L _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view' -> PVar_' x) (view' -> PVar_' xs))))))  | n == consDataCon_RDR = Just $ Right $ BCons x xs-readPat (LL _ (ConPatIn (L _ n) (PrefixCon [])))+readPat (L _ (ConPatIn (L _ n) (PrefixCon [])))   | n == nameRdrName nilDataConName = Just $ Right BNil readPat _ = Nothing

@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}-{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}  {- The matching does a fairly simple unification between the two terms, treating@@ -8,7 +8,6 @@ both ($) and (.) functions on the right.  TRANSFORM PATTERNS-_eval_ - perform deep evaluation, must be used at the top of a RHS _noParen_ - don't bracket this particular item  SIDE CONDITIONS@@ -53,7 +52,7 @@ import Data.Generics.Uniplate.Operations  import Bag-import HsSyn+import GHC.Hs import SrcLoc import BasicTypes import RdrName@@ -63,50 +62,50 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]+readMatch' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch' settings = findIdeas' (concatMap readRule' settings)  readRule' :: HintRule -> [HintRule]-readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unextendInstances -> hintRuleGhcLHS)-                    , hintRuleGhcRHS=(stripLocs' . unextendInstances -> hintRuleGhcRHS)-                    , hintRuleGhcSide=((stripLocs' . unextendInstances <$>) -> hintRuleGhcSide)+readRule' m@HintRule{ hintRuleLHS=(stripLocs' . unextendInstances -> hintRuleLHS)+                    , hintRuleRHS=(stripLocs' . unextendInstances -> hintRuleRHS)+                    , hintRuleSide=((stripLocs' . unextendInstances <$>) -> hintRuleSide)                     } =-   (:) m{ hintRuleGhcLHS=extendInstances hintRuleGhcLHS-        , hintRuleGhcRHS=extendInstances hintRuleGhcRHS-        , hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } $ do-    (l, v1) <- dotVersion' hintRuleGhcLHS-    (r, v2) <- dotVersion' hintRuleGhcRHS+   (:) m{ hintRuleLHS=extendInstances hintRuleLHS+        , hintRuleRHS=extendInstances hintRuleRHS+        , hintRuleSide=extendInstances <$> hintRuleSide } $ do+    (l, v1) <- dotVersion' hintRuleLHS+    (r, v2) <- dotVersion' hintRuleRHS -    guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r))+    guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleSide ++ l ++ r))     if not (null r) then-      [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (dotApps' r), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide }-      , m{ hintRuleGhcLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleGhcRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } ]+      [ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (dotApps' r), hintRuleSide=extendInstances <$> hintRuleSide }+      , m{ hintRuleLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleSide=extendInstances <$> hintRuleSide } ]       else if length l > 1 then-            [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (strToVar "id"), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide }-            , m{ hintRuleGhcLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleGhcRHS=extendInstances (strToVar v1), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide}]+            [ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (strToVar "id"), hintRuleSide=extendInstances <$> hintRuleSide }+            , m{ hintRuleLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleRHS=extendInstances (strToVar v1), hintRuleSide=extendInstances <$> hintRuleSide}]       else []  -- Find a dot version of this rule, return the sequence of app -- prefixes, and the var. dotVersion' :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)] dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)]-dotVersion' (LL _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)-dotVersion' (LL l (OpApp _ x op y)) =+dotVersion' (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)+dotVersion' (L l (OpApp _ x op y)) =   -- In a GHC parse tree, raw sections aren't valid application terms.   -- To be suitable as application terms, they must be enclosed in   -- parentheses.    --   If a == b then   --   x is 'a', op is '==' and y is 'b' and,-  let lSec = addParen' (cL l (SectionL noExt x op)) -- (a == )-      rSec = addParen' (cL l (SectionR noExt op y)) -- ( == b)+  let lSec = addParen' (cL l (SectionL noExtField x op)) -- (a == )+      rSec = addParen' (cL l (SectionR noExtField op y)) -- ( == b)   in (first (lSec :) <$> dotVersion' y) ++ (first (rSec :) <$> dotVersion' x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion' _ = []  --------------------------------------------------------------------- -- PERFORM THE MATCHING -findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]+findIdeas' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList     [ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}     | (name, expr) <- findDecls' decl@@ -117,30 +116,36 @@  -- | A list of root expressions, with their associated names findDecls' :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]-findDecls' x@(LL _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =+findDecls' x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =     [(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs]-findDecls' (LL _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.+findDecls' (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite. findDecls' x = map (fromMaybe "" $ declName x,) $ childrenBi x -matchIdea' :: Scope'+matchIdea' :: Scope            -> String            -> HintRule            -> Maybe (Int, LHsExpr GhcPs)            -> LHsExpr GhcPs            -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)]) matchIdea' sb declName HintRule{..} parent x = do-  let lhs = unextendInstances hintRuleGhcLHS-      rhs = unextendInstances hintRuleGhcRHS-      sa  = unextendInstances hintRuleGhcScope-      nm a b = scopeMatch' (sa, a) (sb, b)-  u <- unifyExp' nm True lhs x+  let lhs = unextendInstances hintRuleLHS+      rhs = unextendInstances hintRuleRHS+      sa  = hintRuleScope+      nm a b = scopeMatch (sa, a) (sb, b)+  (u, extra) <- unifyExp nm True lhs x   u <- validSubst' astEq u    -- Need to check free vars before unqualification, but after subst   -- (with 'e') need to unqualify before substitution (with 'res').-  let (e, tpl) = substitute' u rhs-      res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs)-  guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs)) `Set.isSubsetOf` freeVars' x+  let rhs' | Just fun <- extra = rebracket1' $ noLoc (HsApp noExtField fun rhs)+           | otherwise = rhs+      (e, tpl) = substitute' u rhs'+      noParens = [varToStr $ fromParen' x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]++  u <- pure (removeParens noParens u)++  let res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs')+  guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs')) `Set.isSubsetOf` freeVars' x       -- Check no unexpected new free variables.    -- Check it isn't going to get broken by QuasiQuotes as per #483. If@@ -149,11 +154,14 @@   -- what free vars they make use of.   guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x) -  guard $ checkSide' (unextendInstances <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u+  guard $ checkSide' (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst' u   guard $ checkDefine' declName parent res -  return (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])+  (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst' u) then (mempty, res) else (u, tpl)+  tpl <- pure $ unqualify' sa sb (performSpecial' tpl) +  pure (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])+ --------------------------------------------------------------------- -- SIDE CONDITIONS @@ -161,16 +169,16 @@ checkSide' x bind = maybe True bool x     where       bool :: LHsExpr GhcPs -> Bool-      bool (LL _ (OpApp _ x op y))+      bool (L _ (OpApp _ x op y))         | varToStr op == "&&" = bool x && bool y         | varToStr op == "||" = bool x || bool y         | varToStr op == "==" = expr (fromParen1' x) `astEq` expr (fromParen1' y)-      bool (LL _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y-      bool (LL _ (HsPar _ x)) = bool x+      bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y+      bool (L _ (HsPar _ x)) = bool x -      bool (LL _ (HsApp _ cond (sub -> y)))+      bool (L _ (HsApp _ cond (sub -> y)))         | 'i' : 's' : typ <- varToStr cond = isType typ y-      bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y)))+      bool (L _ (HsApp _ (L _ (HsApp _ cond (sub -> x))) (sub -> y)))           | varToStr cond == "notIn" = and [extendInstances (stripLocs' x) `notElem` map (extendInstances . stripLocs') (universe y) | x <- list x, y <- list y]           | varToStr cond == "notEq" = not (x `astEq` y)       bool x | varToStr x == "noTypeCheck" = True@@ -178,7 +186,7 @@       bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x        expr :: LHsExpr GhcPs -> LHsExpr GhcPs-      expr (LL _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x+      expr (L _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x       expr x = x        isType "Compare" x = True -- Just a hint for proof stuff@@ -189,28 +197,27 @@       isType "Pos" (asInt -> Just x) | x >  0 = True       isType "Neg" (asInt -> Just x) | x <  0 = True       isType "NegZero" (asInt -> Just x) | x <= 0 = True-      isType "LitInt" (LL _ (HsLit _ HsInt{})) = True-      isType "LitInt" (LL _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True-      isType "Var" (LL _ HsVar{}) = True-      isType "App" (LL _ HsApp{}) = True-      isType "InfixApp" (LL _ x@OpApp{}) = True-      isType "Paren" (LL _ x@HsPar{}) = True-      isType "Tuple" (LL _ ExplicitTuple{}) = True+      isType "LitInt" (L _ (HsLit _ HsInt{})) = True+      isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True+      isType "Var" (L _ HsVar{}) = True+      isType "App" (L _ HsApp{}) = True+      isType "InfixApp" (L _ x@OpApp{}) = True+      isType "Paren" (L _ x@HsPar{}) = True+      isType "Tuple" (L _ ExplicitTuple{}) = True -      isType typ (LL _ x) =+      isType typ (L _ x) =         let top = showConstr (toConstr x) in         typ == top-      isType _ _ = False -- {-# COMPLETE LL#-}        asInt :: LHsExpr GhcPs -> Maybe Integer-      asInt (LL _ (HsPar _ x)) = asInt x-      asInt (LL _ (NegApp _ x _)) = negate <$> asInt x-      asInt (LL _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x-      asInt (LL _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x+      asInt (L _ (HsPar _ x)) = asInt x+      asInt (L _ (NegApp _ x _)) = negate <$> asInt x+      asInt (L _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x+      asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x       asInt _ = Nothing        list :: LHsExpr GhcPs -> [LHsExpr GhcPs]-      list (LL _ (ExplicitList _ _ xs)) = xs+      list (L _ (ExplicitList _ _ xs)) = xs       list x = [x]        sub :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -222,8 +229,8 @@ checkDefine' :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool checkDefine' declName Nothing y =   let funOrOp expr = case expr of-        LL _ (HsApp _ fun _) -> funOrOp fun-        LL _ (OpApp _ _ op _) -> funOrOp op+        L _ (HsApp _ fun _) -> funOrOp fun+        L _ (OpApp _ _ op _) -> funOrOp op         other -> other    in declName /= varToStr (transformBi unqual' $ funOrOp y) checkDefine' _ _ _ = True@@ -231,26 +238,24 @@ --------------------------------------------------------------------- -- TRANSFORMATION --- If it has '_eval_' do evaluation on it.+-- If it has '_noParen_', remove the brackets (if exist). performSpecial' :: LHsExpr GhcPs -> LHsExpr GhcPs-performSpecial' = transform fNoParen . fEval+performSpecial' = transform fNoParen   where-    fEval, fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs-    fEval (LL _ (HsApp _ e x)) | varToStr e == "_eval_" = reduce' x-    fEval x = x-    fNoParen (LL _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x+    fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs+    fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x     fNoParen x = x  -- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.-unqualify' :: Scope' -> Scope' -> LHsExpr GhcPs -> LHsExpr GhcPs+unqualify' :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify' from to = transformBi f   where     f :: Located RdrName -> Located RdrName     f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x-    f x = scopeMove' (from, x) to+    f x = scopeMove (from, x) to  addBracket' :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs-addBracket' (Just (i, p)) c | needBracketOld' i p c = noLoc $ HsPar noExt c+addBracket' (Just (i, p)) c | needBracketOld' i p c = noLoc $ HsPar noExtField c addBracket' _ x = x  -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a@@ -260,6 +265,6 @@ addBracketTy'= transformBi f   where     f :: LHsType GhcPs -> LHsType GhcPs-    f (LL _ (HsAppTy _ t x@(LL _ HsAppTy{}))) =-      noLoc (HsAppTy noExt t (noLoc (HsParTy noExt x)))+    f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =+      noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x)))     f x = x

@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE LambdaCase, ViewPatterns, PatternGuards, FlexibleContexts #-} {-     Find and match: @@ -13,7 +13,7 @@ yes = do _ <- mapM print a; return b -- mapM_ print a no = mapM print a no = do foo ; mapM print a-yes = do (bar+foo) -- (bar+foo)+yes = do (bar+foo) -- no = do bar ; foo yes = do bar; a <- foo; return a -- do bar; foo no = do bar; a <- foo; return b@@ -27,8 +27,8 @@ yes = do x <- bar $ baz; return (f $ g x) no = do x <- bar; return (f x x) {-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook-yes = do x <- return y; foo x -- @Suggestion do let x = y; foo x-yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x+yes = do x <- return y; foo x -- @Suggestion let x = y+yes = do x <- return $ y + z; foo x -- let x = y + z no = do x <- return x; foo x no = do x <- return y; x <- return y; foo x yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return ()@@ -39,31 +39,33 @@ folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait main = "wait" ~> do f a $ sleep 10-main = print do 17 + 25-main = print do 17 -- 17-main = f $ do g a $ sleep 10 -- g a $ sleep 10-main = do f a $ sleep 10 -- f a $ sleep 10+{-# LANGUAGE BlockArguments #-}; main = print do 17 + 25+{-# LANGUAGE BlockArguments #-}; main = print do 17 --+main = f $ do g a $ sleep 10 --+main = do f a $ sleep 10 -- main = do foo x; return 3; bar z -- do foo x; bar z main = void $ forM_ f xs -- forM_ f xs main = void $ forM f xs -- void $ forM_ f xs main = do _ <- forM_ f xs; bar -- forM_ f xs main = do bar; forM_ f xs; return () -- do bar; forM_ f xs main = do a; when b c; return () -- do a; when b c+bar = 1 * do {\x -> x+x} + y </TEST> -}   module Hint.Monad(monadHint) where -import Hint.Type(DeclHint',Idea,ideaNote,warn',toSS',suggest',Note(Note))+import Hint.Type(DeclHint',Idea(..),ideaNote,warn',warnRemove,toSS',suggest',Note(Note)) -import HsSyn+import GHC.Hs import SrcLoc import BasicTypes import TcEvidence import RdrName import OccName import Bag+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util @@ -86,41 +88,53 @@   case x of     (view' -> App2' op x1 x2) | isTag ">>" op -> f x1     (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag ">>=" op -> f x1-    (LL l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExt op) x-    (LL l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExt op dol) x-    (LL loc (HsDo _ _ (LL _ [LL _ (BodyStmt _ y _ _ )]))) -> [warn' "Redundant do" x y [Replace Expr (toSS' x) [("y", toSS' y)] "y"] | not $ doOperator parent y]-    (LL loc (HsDo _ DoExpr (L _ xs))) ->-      monadSteps (cL loc . HsDo noExt DoExpr . noLoc) xs ++-      [suggest' "Use let" x (cL loc (HsDo noExt DoExpr (noLoc y)) :: LHsExpr GhcPs) rs | Just (y, rs) <- [monadLet xs]] ++-      concat [f x | (LL _ (BodyStmt _ x _ _)) <- init xs] ++-      concat [f x | (LL _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs]+    (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExtField op) x+    (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExtField op dol) x+    (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) ->+      let doOrMDo = case ctx of MDoExpr -> "mdo"; _ -> "do"+       in [ warnRemove ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS' x) [("y", toSS' y)] "y"]+          | not $ doAsBrackets parent y ]+    (L loc (HsDo _ DoExpr (L _ xs))) ->+      monadSteps (cL loc . HsDo noExtField DoExpr . noLoc) xs +++      [suggest' "Use let" from to [r] | (from, to, r) <- monadLet xs] +++      concat [f x | (L _ (BodyStmt _ x _ _)) <- init xs] +++      concat [f x | (L _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs]     _ -> []   where     f = monadNoResult (fromMaybe "" decl) id     seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn' "Redundant void" (wrap x) x [] | returnsUnit x]+    doSpan doOrMDo = \case+      UnhelpfulSpan s -> UnhelpfulSpan s+      RealSrcSpan s ->+        let start = realSrcSpanStart s+            end = mkRealSrcLoc (srcSpanFile s) (srcLocLine start) (srcLocCol start + length doOrMDo)+         in RealSrcSpan (mkRealSrcSpan start end) --- Sometimes people write 'a * do a + b', to avoid brackets.--- or using BlockArguments they can write 'a do a b'-doOperator :: (Eq a, Num a) => Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-doOperator (Just (2, LL _ (OpApp _ _ op _ )))  (LL _ OpApp {}) | not $ isDol op = True-doOperator (Just (1, LL _ HsApp{})) b | not $ isAtom' b = True-doOperator _ _ = False+-- Sometimes people write 'a * do a + b', to avoid brackets,+-- or using BlockArguments they can write 'a do a b',+-- or using indentation a * do {\b -> c} * d+-- Return True if they are using do as brackets+doAsBrackets :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool+doAsBrackets (Just (2, L _ (OpApp _ _ op _ ))) _ | isDol op = False -- not quite atomic, but close enough+doAsBrackets (Just (i, o)) x = needBracket' i o x+doAsBrackets Nothing x = False + returnsUnit :: LHsExpr GhcPs -> Bool-returnsUnit (LL _ (HsPar _ x)) = returnsUnit x-returnsUnit (LL _ (HsApp _ x _)) = returnsUnit x-returnsUnit (LL _ (OpApp _ x op _)) | isDol op = returnsUnit x-returnsUnit (LL _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs+returnsUnit (L _ (HsPar _ x)) = returnsUnit x+returnsUnit (L _ (HsApp _ x _)) = returnsUnit x+returnsUnit (L _ (OpApp _ x op _)) | isDol op = returnsUnit x+returnsUnit (L _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs returnsUnit _ = False  -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]-monadNoResult inside wrap (LL l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExt) x-monadNoResult inside wrap (LL l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExt x y)) x-monadNoResult inside wrap (LL l (OpApp _ x tag@(LL _ (HsVar _ (L _ op))) y))-    | isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExt x tag y)) x-    | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExt x tag) y+monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExtField) x+monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExtField x y)) x+monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y))+    | isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExtField x tag y)) x+    | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExtField x tag) y monadNoResult inside wrap x     | x2 : _ <- filter (`isTag` x) badFuncs     , let x3 = x2 ++ "_"@@ -133,53 +147,53 @@            -> [ExprLStmt GhcPs] -> [Idea]  -- Rewrite 'do return x; $2' as 'do $2'.-monadStep wrap os@(o@(LL _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))+monadStep wrap os@(o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))   = [warn' ("Redundant " ++ ret) (wrap os) (wrap xs) [Delete Stmt (toSS' o)]]  -- Rewrite 'do a <- $1; return a' as 'do $1'.-monadStep wrap o@[ g@(LL _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))-                  , q@(LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ v)))) _ _))]+monadStep wrap o@[ g@(L _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))+                  , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))]   | occNameString (rdrNameOcc p) == occNameString (rdrNameOcc v)-  = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr])+  = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])       [Replace Stmt (toSS' g) [("x", toSS' x)] "x", Delete Stmt (toSS' q)]]  -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.-monadStep wrap o@(g@(LL _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(LL _ (BodyStmt _ (view' -> Var_' v) _ _)):xs)+monadStep wrap o@(g@(L _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(L _ (BodyStmt _ (view' -> Var_' v) _ _)):xs)   | p == v && v `notElem` varss' xs-  = let app = noLoc $ HsApp noExt (strToVar "join") x-        body = noLoc $ BodyStmt noExt (rebracket1' app) noSyntaxExpr noSyntaxExpr+  = let app = noLoc $ HsApp noExtField (strToVar "join") x+        body = noLoc $ BodyStmt noExtField (rebracket1' app) noSyntaxExpr noSyntaxExpr         stmts = body : xs     in [warn' "Use join" (wrap o) (wrap stmts) r]   where r = [Replace Stmt (toSS' g) [("x", toSS' x)] "join x", Delete Stmt (toSS' q)]  -- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as -- 'do <return ()>; $1'.-monadStep wrap (o@(LL loc (BindStmt _ p x _ _)) : rest)-    | isPWildCard' p, returnsUnit x-    = let body = cL loc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs+monadStep wrap (o@(L loc (BindStmt _ p x _ _)) : rest)+    | isPWildcard p, returnsUnit x+    = let body = cL loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs       in [warn' "Redundant variable capture" o body []]  -- Redundant unit return : 'do <return ()>; return ()'. monadStep-  wrap o@[ LL _ (BodyStmt _ x _ _)-         , LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ unit)))) _ _)]+  wrap o@[ L _ (BodyStmt _ x _ _)+         , L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _)]      | returnsUnit x, occNameString (rdrNameOcc unit) == "()"   = [warn' ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]  -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap-  o@[g@(LL _ (BindStmt _ (view' -> PVar_' u) x _ _))-    , q@(LL _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))]+  o@[g@(L _ (BindStmt _ (view' -> PVar_' u) x _ _))+    , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))]   | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars' (f : fs)   =-      [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExt (noLoc $ OpApp noExt (foldl' (\acc e -> noLoc $ OpApp noExt acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])+      [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])       [Replace Stmt (toSS' g) (("x", toSS' x):zip vs (toSS' <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS' q)]]   where     isSimple (fromApps' -> xs) = all isAtom' (x : xs)     vs = ('f':) . show <$> [0..]      notDol :: LHsExpr GhcPs -> Bool-    notDol (LL _ (OpApp _ _ op _)) = not $ isDol op+    notDol (L _ (OpApp _ _ op _)) = not $ isDol op     notDol _ = True  monadStep _ _ = []@@ -190,40 +204,39 @@ monadSteps _ _ = []  -- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'.-monadLet :: [ExprLStmt GhcPs] -> Maybe ([ExprLStmt GhcPs], [Refactoring R.SrcSpan])-monadLet xs = if null rs then Nothing else Just (ys, rs)+monadLet :: [ExprLStmt GhcPs] -> [(ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)]+monadLet xs = mapMaybe mkLet xs   where-    (ys, catMaybes -> rs) = unzip $ map mkLet xs-    vs = concatMap pvars' [p | (LL _ (BindStmt _ p _ _ _)) <- xs]+    vs = concatMap pvars' [p | (L _ (BindStmt _ p _ _ _)) <- xs] -    mkLet :: ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring R.SrcSpan))-    mkLet g@(LL _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ ))+    mkLet :: ExprLStmt GhcPs -> Maybe (ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)+    mkLet x@(L _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ ))       | p `notElem` vars' y, p `notElem` delete p vs-      = (template p y, Just refact)+      = Just (x, template p y, refact)       where-        refact = Replace Stmt (toSS' g) [("lhs", toSS' v), ("rhs", toSS' y)]+        refact = Replace Stmt (toSS' x) [("lhs", toSS' v), ("rhs", toSS' y)]                       (unsafePrettyPrint $ template "lhs" (strToVar "rhs"))-    mkLet x = (x, Nothing)+    mkLet _ = Nothing      template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs     template lhs rhs =         let p = noLoc $ mkRdrUnqual (mkVarOcc lhs)-            grhs = noLoc (GRHS noExt [] rhs)-            grhss = GRHSs noExt [grhs] (noLoc (EmptyLocalBinds noExt))-            match = noLoc $ Match noExt (FunRhs p Prefix NoSrcStrict) [] grhss-            fb = noLoc $ FunBind noExt p (MG noExt (noLoc [match]) Generated) WpHole []+            grhs = noLoc (GRHS noExtField [] rhs)+            grhss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))+            match = noLoc $ Match noExtField (FunRhs p Prefix NoSrcStrict) [] grhss+            fb = noLoc $ FunBind noExtField p (MG noExtField (noLoc [match]) Generated) WpHole []             binds = unitBag fb-            valBinds = ValBinds noExt binds []-            localBinds = noLoc $ HsValBinds noExt valBinds-         in noLoc $ LetStmt noExt localBinds+            valBinds = ValBinds noExtField binds []+            localBinds = noLoc $ HsValBinds noExtField valBinds+         in noLoc $ LetStmt noExtField localBinds  fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)-fromApplies (LL _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x)-fromApplies (LL _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x+fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x)+fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x)  fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)-fromRet (LL _ (HsPar _ x)) = fromRet x-fromRet (LL _ (OpApp _ x (LL _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExt x z)-fromRet (LL _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y)+fromRet (L _ (HsPar _ x)) = fromRet x+fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExtField x z)+fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing

@@ -15,25 +15,25 @@     Don't suggest for FFI, since they match their C names  <TEST>-data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest-data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar+data Yes = Foo | Bar'Test+data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar @NoRefactor data No = a :::: b data Yes = Foo {bar_cap :: Int} data No = FOO | BarBAR | BarBBar-yes_foo = yes_foo + yes_foo -- yesFoo = ...-yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ...+yes_foo = yes_foo + yes_foo -- yesFoo = ... @NoRefactor+yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... @NoRefactor no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1-semiring'laws = 1 -- semiringLaws = ...-data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB+semiring'laws = 1+data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB @NoRefactor case_foo = 1 test_foo = 1-cast_foo = 1 -- castFoo = ...+cast_foo = 1 -- castFoo = ... @NoRefactor replicateM_ = 1 _foo__ = 1 section_1_1 = 1-runMutator# = 1+runMutator# = 1  @NoRefactor foreign import ccall hexml_node_child :: IO () </TEST> -}@@ -41,7 +41,7 @@  module Hint.Naming(namingHint) where -import Hint.Type (Idea,DeclHint',suggest',isSym,toSrcSpan',ghcModule)+import Hint.Type (Idea,DeclHint',suggest',toSrcSpan',ghcModule) import Data.Generics.Uniplate.Operations import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data@@ -52,12 +52,13 @@  import BasicTypes import FastString-import HsDecls-import HsExtension-import HsSyn+import GHC.Hs.Decls+import GHC.Hs.Extension+import GHC.Hs import OccName import SrcLoc +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls import GHC.Util  namingHint :: DeclHint'@@ -74,7 +75,7 @@     where         suggestedNames =             [ (originalName, suggestedName)-            | not $ isForD' originalDecl+            | not $ isForD originalDecl             , originalName <- nubOrd $ getNames originalDecl             , Just suggestedName <- [suggestName originalName]             , not $ suggestedName `Set.member` seen@@ -82,23 +83,23 @@         replacedDecl = replaceNames suggestedNames originalDecl  shorten :: LHsDecl GhcPs -> LHsDecl GhcPs-shorten (LL locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) FromSource) _ _))) =-    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 (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (L locMatches matches) FromSource) _ _))) =+    L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})+shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =+    L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x  shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)-shortenMatch (LL locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =-    LL locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}}+shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =+    L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} shortenMatch x = x  shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)-shortenLGRHS (LL locGRHS (GRHS ttg0 guards (LL locExpr _))) =-    LL locGRHS (GRHS ttg0 guards (cL locExpr dots))+shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =+    L locGRHS (GRHS ttg0 guards (cL locExpr dots))     where         dots :: HsExpr GhcPs-        dots = HsLit NoExt (HsString (SourceText "...") (mkFastString "..."))+        dots = HsLit noExtField (HsString (SourceText "...") (mkFastString "...")) shortenLGRHS x = x  getNames :: LHsDecl GhcPs -> [String]@@ -109,13 +110,16 @@     concatMap (map unsafePrettyPrint . getConNames . unLoc) cons getConstructorNames _ = [] +isSym (x:_) = not $ isAlpha x || x `elem` "_'"+isSym _ = False+ suggestName :: String -> Maybe String suggestName original     | isSym original || good || not (any isLower original) || any isDigit original ||         any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing     | otherwise = Just $ f original     where-        good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' original+        good = all isAlphaNum $ drp '_' $ drp '#' $ filter (/= '\'') $ reverse $ drp '_' original         drp x = dropWhile (== x)          f xs = us ++ g ys

@@ -5,24 +5,25 @@     quantified data types because it is not valid.  <TEST>-data Foo = Foo Int -- newtype Foo = Foo Int-data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq)-data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show-data Foo a b = Foo a -- newtype Foo a b = Foo a+data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor: refactoring for "Use newtype" is not implemented+data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) @NoRefactor+data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show @NoRefactor+data Foo a b = Foo a -- newtype Foo a b = Foo a @NoRefactor data Foo = Foo { field1, field2 :: Int}-data S a = forall b . Show b => S b-{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a)+data S a = forall b . Show b => S b @NoRefactor: apply-refact 0.6 requires RankNTypes pragma+{-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) @NoRefactor data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a-data Foo a = () => Foo a -- newtype Foo a = Foo a-data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int-data A = A {b :: !C} -- newtype A = A {b :: C}-data A = A Int#+data Foo a = () => Foo a -- newtype Foo a = Foo a @NoRefactor+data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int @NoRefactor+data A = A {b :: !C} -- newtype A = A {b :: C} @NoRefactor+data A = A Int#  @NoRefactor {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #) {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)}-data A = A () -- newtype A = A ()+data A = A () -- newtype A = A () @NoRefactor newtype Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo Int deriving stock Show@@ -33,8 +34,8 @@ import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN')  import Data.List (isSuffixOf)-import HsDecls-import HsSyn+import GHC.Hs.Decls+import GHC.Hs import Outputable import SrcLoc @@ -49,12 +50,12 @@ newtypeHintDecl _ = []  newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]-newTypeDerivingStrategiesHintDecl decl@(LL _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =+newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =     [ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = []  hasAllStrategies :: HsDataDefn GhcPs -> Bool-hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (LL _ xs)) = all hasStrategyClause xs+hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs hasAllStrategies _ = False  isData :: HsDataDefn GhcPs -> Bool@@ -63,7 +64,7 @@ isData _ = False  hasStrategyClause :: LHsDerivingClause GhcPs -> Bool-hasStrategyClause (LL _ (HsDerivingClause _ (Just _) _)) = True+hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True hasStrategyClause _ = False  data WarnNewtype = WarnNewtype@@ -79,12 +80,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 (LL loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [LL _ constructor] _))))+singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [L _ constructor] _))))     | Just inType <- simpleCons constructor =         Just WarnNewtype-              { newDecl = LL loc $ TyClD ext decl {tcdDataDefn = dataDef+              { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef                   { dd_ND = NewType-                  , dd_cons = map (\(LL consloc x) -> LL consloc $ dropConsBang x) $ dd_cons dataDef+                  , dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef                   }}               , insideType = inType               }@@ -93,12 +94,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 [LL _ inType]) _)+simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [L _ inType]) _)     | emptyOrNoContext context     , not $ isUnboxedTuple inType     , not $ isHashy inType     = Just inType-simpleCons (ConDeclH98 _ _ _ [] context (RecCon (LL _ [LL _ (ConDeclField _ [_] (LL _ inType) _)])) _)+simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)     | emptyOrNoContext context     , not $ isUnboxedTuple inType     , not $ isHashy inType@@ -115,18 +116,18 @@  emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool emptyOrNoContext Nothing = True-emptyOrNoContext (Just (LL _ [])) = True+emptyOrNoContext (Just (L _ [])) = True emptyOrNoContext _ = False  -- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas! dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =     decl {con_args = PrefixCon $ map getBangType fields}-dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (LL recloc conDeclFields)) _) =+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =     decl {con_args = RecCon $ cL recloc $ removeUnpacksRecords conDeclFields}     where         removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]-        removeUnpacksRecords = map (\(LL conDeclFieldLoc x) -> LL conDeclFieldLoc $ removeConDeclFieldUnpacks x)+        removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)          removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs         removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =

@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, PatternGuards #-}+{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-}  {-     Improve the structure of code@@ -16,7 +16,7 @@       | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y-foo x = x + x where -- foo x = x + x+foo x = x + x where -- @NoRefactor: refactoring for "Redundant where" is not implemented foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x@@ -25,28 +25,30 @@ foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x-foo = case v of !True -> x -- True-foo = case v of !(Just x) -> x -- (Just x)-foo = case v of !(x : xs) -> x -- (x:xs)-foo = case v of !1 -> x -- 1-foo = case v of !x -> x-foo = case v of !(I# x) -> y -- (I# x)+foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.+foo = case v of !True -> x -- True @NoRefactor: apply-refact requires BangPatterns pragma+{-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True+{-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x)+{-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs)+{-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1+{-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x+{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) @NoRefactor foo = let ~x = 1 in y -- x foo = let ~(x:xs) = y in z-foo = let !x = undefined in y-foo = let !(I# x) = 4 in x-foo = let !(Just x) = Nothing in 3-foo = 1 where f !False = 2 -- False-foo = 1 where !False = True-foo = 1 where g (Just !True) = Nothing -- True-foo = 1 where Just !True = Nothing-foo otherwise = 1 -- _+{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y+{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x @NoRefactor+{-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3+{-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False+{-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True+{-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True+{-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing+foo otherwise = 1 -- _ @NoRefactor foo ~x = y -- x {-# LANGUAGE Strict #-} foo ~x = y-foo !(x, y) = x -- (x, y)-foo ![x] = x -- [x]+{-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y)+{-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x] foo !Bar { bar = x } = x -- Bar { bar = x }-l !(() :: ()) = x -- (() :: ())+{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ()) foo x@_ = x -- x foo x@Foo = x </TEST>@@ -55,7 +57,7 @@  module Hint.Pattern(patternHint) where -import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan,ghcSpanToHSE,suggest',warn')+import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan',suggest',suggestRemove,warn') import Data.Generics.Uniplate.Operations import Data.Function import Data.List.Extra@@ -65,7 +67,7 @@ import Refact.Types hiding (RType(Pattern, Match), SrcSpan) import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) -import HsSyn+import GHC.Hs import SrcLoc import RdrName import OccName@@ -73,6 +75,7 @@ import BasicTypes  import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr  patternHint :: DeclHint'@@ -80,16 +83,15 @@     concatMap (uncurry hints . swap) (asPattern x) ++     -- PatBind (used in 'let' and 'where') contains lazy-by-default     -- patterns, everything else is strict.-    concatMap (patHint strict False) (located [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]]) ++-    concatMap (patHint strict True) (located (universeBi $ transformBi noPatBind x)) +++    concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] +++    concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++     concatMap expHint (universeBi x)   where-    located ps = [p | p@XPat{} <- ps]  -- restrict attention to patterns with locs     exts = nubOrd $ concatMap snd (langExts (pragmas (ghcAnnotations modu))) -- language extensions enabled at source     strict = "Strict" `elem` exts      noPatBind :: LHsBind GhcPs -> LHsBind GhcPs-    noPatBind (LL loc a@PatBind{}) = cL loc a{pat_lhs=noLoc (WildPat noExt)}+    noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)}     noPatBind x = x  {-@@ -105,14 +107,14 @@ -}  hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]-hints gen (Pattern l rtype pat (GRHSs _ [LL _ (GRHS _ [] bod)] bind))-  | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExt guards bind)) [refactoring]]+hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))+  | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]]   where     rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]     rawGuards = asGuards bod      mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))-    mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr noSyntaxExpr]+    mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]      guards :: [LGRHS GhcPs (LHsExpr GhcPs)]     guards = map (noLoc . uncurry mkGuard) rawGuards@@ -123,8 +125,7 @@       -- Check if the expression has been injected or is natural.       zipWith checkLoc ps ['1' .. '9']       where-        checkLoc p@(LL l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p)-        checkLoc _ v = undefined -- {-# COMPLETE LL #-}+        checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p)      patSubts =       case pat of@@ -138,98 +139,103 @@     toString (Left e) = e     toString (Right (v, _)) = strToVar v     toString' (Left e) = e-    toString' (Right (v, _)) = strToPat' v+    toString' (Right (v, _)) = strToPat v -    template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExt templateGuards bind)) [])+    template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) [])      f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]     f = rights-    refactoring = Replace rtype (toRefactSrcSpan$ ghcSpanToHSE l) (f patSubts ++ f guardSubts ++ f exprSubts) template-hints gen (Pattern l t pats o@(GRHSs _ [LL _ (GRHS _ [test] bod)] bind))+    refactoring = Replace rtype (toRefactSrcSpan' l) (f patSubts ++ f guardSubts ++ f exprSubts) template+hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind))   | unsafePrettyPrint test `elem` ["otherwise", "True"]-  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExt [] bod)]}) [Delete Stmt (toSS' test)]]-hints gen (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds-  = [gen "Redundant where" (Pattern l t pats bod{grhssLocalBinds=noLoc (EmptyLocalBinds noExt)}) []]+  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS' test)]]+hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds+  = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]]   where     f :: LHsLocalBinds GhcPs -> Bool-    f (LL _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag-    f (LL _ (HsIPBinds _ (IPBinds _ l))) = null l+    f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag+    f (L _ (HsIPBinds _ (IPBinds _ l))) = null l     f _ = False-hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, LL _ (GRHS _ [test] bod))) binds))+    whereSpan = case l of+      UnhelpfulSpan s -> UnhelpfulSpan s+      RealSrcSpan s ->+        let end = realSrcSpanEnd s+            start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)+         in RealSrcSpan (mkRealSrcSpan start end)+hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds))   | unsafePrettyPrint test == "True"   = let tag = noLoc (mkRdrUnqual $ mkVarOcc "otherwise")-        otherwise_ = noLoc $ BodyStmt noExt (noLoc (HsVar noExt tag)) noSyntaxExpr noSyntaxExpr in-      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExt [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]]+        otherwise_ = noLoc $ BodyStmt noExtField (noLoc (HsVar noExtField tag)) noSyntaxExpr noSyntaxExpr in+      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]] hints _ _ = []  asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]-asGuards (LL _ (HsPar _ x)) = asGuards x-asGuards (LL _ (HsIf _ _ a b c)) = (a, b) : asGuards c-asGuards x = [(noLoc (HsVar noExt (noLoc (mkRdrUnqual $ mkVarOcc "otherwise"))), x)]+asGuards (L _ (HsPar _ x)) = asGuards x+asGuards (L _ (HsIf _ _ a b c)) = (a, b) : asGuards c+asGuards x = [(noLoc (HsVar noExtField (noLoc (mkRdrUnqual $ mkVarOcc "otherwise"))), x)] -data Pattern = Pattern SrcSpan R.RType [Pat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))+data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))  -- Invariant: Number of patterns may not change asPattern :: LHsDecl GhcPs  -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]-asPattern (LL loc x) = concatMap decl (universeBi x)+asPattern (L loc x) = concatMap decl (universeBi x)   where     decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]-    decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (cL loc o :: LHsBind GhcPs) (noLoc (PatBind noExt pat rhs ([], [])) :: LHsBind GhcPs) rs)]-    decl (FunBind _ _ (MG _ (LL _ xs) _) _ _) = map match xs+    decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]+    decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs     decl _ = []      match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)-    match o@(LL loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExt ctx  pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)-    match _ = undefined -- {-# COMPLETE LL #-}-asPattern _ = [] -- {-# COMPLETE LL #-}+    match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExtField ctx  pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)+    match _ = undefined -- {-# COMPLETE L #-}  -- First Bool is if 'Strict' is a language extension. Second Bool is -- if this pattern in this context is going to be evaluated strictly.-patHint :: Bool -> Bool -> Pat GhcPs -> [Idea]-patHint _ _ o@(LL _ (ConPatIn name (PrefixCon args)))-  | length args >= 3 && all isPWildCard' args =-  let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (Pat GhcPs)-      new        = ConPatIn name (RecCon rec_fields) :: Pat GhcPs+patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]+patHint _ _ o@(L _ (ConPatIn name (PrefixCon args)))+  | length args >= 3 && all isPWildcard args =+  let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)+      new        = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs   in   [suggest' "Use record patterns" o new [Replace R.Pattern (toSS' o) [] (unsafePrettyPrint new)]]-patHint _ _ o@(LL _ (VarPat _ (L _ name)))+patHint _ _ o@(L _ (VarPat _ (L _ name)))   | occNameString (rdrNameOcc name) == "otherwise" =-    [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExt) :: Pat GhcPs) []]-patHint lang strict o@(LL _ (BangPat _ (LL _ x)))-  | strict, f x = [warn' "Redundant bang pattern" o x [r]]+    [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]+patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))+  | strict, f x = [warn' "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]   where     f :: Pat GhcPs -> Bool-    f (ParPat _ (LL _ x)) = f x-    f (AsPat _ _ (LL _ x)) = f x+    f (ParPat _ (L _ x)) = f x+    f (AsPat _ _ (L _ x)) = f x     f LitPat {} = True     f NPat {} = True     f ConPatIn {} = True     f TuplePat {} = True     f ListPat {} = True-    f (SigPat _ (LL _ p) _) = f p+    f (SigPat _ (L _ p) _) = f p     f _ = False-    r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x"-patHint False _ o@(LL _ (LazyPat _ (LL _ x)))-  | f x = [warn' "Redundant irrefutable pattern" o x [r]]+    r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x"+patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))+  | f x = [warn' "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]   where     f :: Pat GhcPs -> Bool-    f (ParPat _ (LL _ x)) = f x-    f (AsPat _ _ (LL _ x)) = f x+    f (ParPat _ (L _ x)) = f x+    f (AsPat _ _ (L _ x)) = f x     f WildPat{} = True     f VarPat{} = True     f _ = False-    r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x"-patHint _ _ o@(LL _ (AsPat _ v (LL _ (WildPat _)))) =+    r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x"+patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =   [warn' "Redundant as-pattern" o v []] patHint _ _ _ = []  expHint :: LHsExpr GhcPs -> [Idea]  -- Note the 'FromSource' in these equations (don't warn on generated match groups).-expHint o@(LL _ (HsCase _ _ (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (WildPat _)] (GRHSs _ [LL _ (GRHS _ [] e)] (LL  _ (EmptyLocalBinds _)))) ]) FromSource ))) =+expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource ))) =   [suggest' "Redundant case" o e [r]]   where     r = Replace Expr (toSS' o) [("x", toSS' e)] "x"-expHint o@(LL _ (HsCase _ (LL _ (HsVar _ (L _ x))) (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (VarPat _ (L _ y))] (GRHSs _ [LL _ (GRHS _ [] e)] (LL  _ (EmptyLocalBinds _)))) ]) FromSource )))+expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource )))   | occNameString (rdrNameOcc x) == occNameString (rdrNameOcc y) =       [suggest' "Redundant case" o e [r]]   where

@@ -14,12 +14,13 @@ {-# OPTIONS     -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}-{-# OPTIONS_GHC -fglasgow-exts #-} -- ???+{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-}-{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-}+{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag+{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} @NoRefactor: the two pragmas are switched in the refactoring output {-# OPTIONS_GHC -cpp #-} \-{-# LANGUAGE CPP, Text #-} --+{-# LANGUAGE CPP, Text #-} -- @NoRefactor {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \@@ -30,7 +31,7 @@  module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea',prettyExtension,glasgowExts)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea') import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe@@ -41,6 +42,7 @@ import SrcLoc  import GHC.Util+import DynFlags  pragmaHint :: ModuHint pragmaHint _ modu =@@ -97,10 +99,10 @@           mkLanguage = rawIdea' Hint.Type.Warning "Use LANGUAGE pragmas"  languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]-languageDupes ( (a@(LL l _), les) : cs ) =+languageDupes ( (a@(L 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']+       else [pragmaIdea (MultiComment a b (mkLangExts l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les']   ) ++ languageDupes cs languageDupes _ = [] @@ -108,7 +110,7 @@ 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 "-fglasgow-exts" = Just $ map show glasgowExtsFlags strToLanguage _ = Nothing  -- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,@@ -126,7 +128,7 @@ optToLanguage :: (Located AnnotationComment, [String])                -> [String]                -> Maybe (Maybe (Located AnnotationComment), [String])-optToLanguage (LL loc _, flags) langExts+optToLanguage (L 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