packages feed

hlint 2.1.26 → 3.10

raw patch · 113 files changed

Files

+ .hlint.yaml view
@@ -0,0 +1,78 @@+# HLint configuration file+# https://github.com/ndmitchell/hlint+##########################++# Hints that apply only to the HLint source code++#####################################################################+## GROUPS OF HINTS WE TURN ON++- group: {name: future, enabled: true}+- group: {name: extra, enabled: true}+++#####################################################################+## RESTRICTIONS++- extensions:+  - default: false+  - name: [ImportQualifiedPost]+  - name: [DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, OverloadedStrings]+  - name: [MultiWayIf, PatternGuards, RecordWildCards, ViewPatterns, PatternSynonyms, TupleSections, LambdaCase]+  - name: [Rank2Types, ScopedTypeVariables]+  - name: [ExistentialQuantification, MultiParamTypeClasses, NamedFieldPuns]+  - name: [FlexibleContexts, FlexibleInstances]+  - name: [PackageImports]+  - name: [ConstraintKinds, RankNTypes, TypeFamilies]+  - name: [TemplateHaskell]+  - name: [DerivingVia, DeriveGeneric, DataKinds]+  - {name: CPP, within: [HsColour, Config.Yaml, Test.Annotations]} # so it can be disabled to avoid GPL code+  - {name: CPP, within: CmdLine} # Don't think this one is really necessary++- flags:+  - default: false+  - {name: [-Wno-missing-fields, -fno-cse, -O0], within: CmdLine} # for cmdargs+  - {name: [-Wno-incomplete-patterns, -Wno-overlapping-patterns]} # the pattern match checker is not very good++- modules:+  - {name: [Data.Set, Data.HashSet], as: Set}+  - {name: [Data.Map, Data.HashMap.Strict, Data.HashMap.Lazy], as: Map}+  - {name: Control.Arrow, within: []}++- functions:+  - {name: unsafeInterleaveIO, within: Parallel}+  - {name: unsafePerformIO, within: [Util.exitMessageImpure, Test.Util.ref, Timing]}+  - {name: unsafeCoerce, within: [Util.gzip, GHC.Util.Refact.Utils]}+  - {name: Data.List.nub, within: []}+  - {name: Data.List.nubBy, within: []}+  - {name: Data.List.NonEmpty.nub, within: []}+  - {name: Data.List.NonEmpty.nubBy, within: []}+++#####################################################################+## OTHER HINTS++- warn: {name: Use explicit module export list}+++#####################################################################+## HINTS++- error: {lhs: idea Warning, rhs: warn}+- error: {lhs: idea Suggestion, rhs: suggest}+- error: {lhs: ideaN Warning, rhs: warnN}+- error: {lhs: ideaN Suggestion, rhs: suggestN}++- error: {lhs: occNameString (occName (unLoc x)), rhs: rdrNameStr x}+- error: {lhs: occNameString (occName x), rhs: occNameStr x}+- error: {lhs: noLoc (HsVar noExtField (noLoc (mkRdrUnqual (mkVarOcc x)))), rhs: strToVar x}++#####################################################################+## IGNORES++# doesn't fit with the other statements+- ignore: {name: Use let, within: [HLint, Test.All]}+# this const has meaningful argument names+- ignore: {name: Use const, within: Config.Yaml}+# TEMPORARY: this lint is deleted on HEAD+- ignore: {name: Use String}
CHANGES.txt view
@@ -1,5 +1,392 @@ Changelog for HLint (* = breaking change) +3.10, released 2024-02-02+    #1617, hints for when x <*> y could be y, e.g. []+*   #1594, upgrade to GHC 9.12+    #1568, add mapMaybe f (reverse x) ==> reverse (mapMaybe f x)+    #1569, avoid redundant Foldable.toList calls in Foldable operations+    #1571, rename a few hints to make them clearer+    #1599, add translated 0 0 hint for CodeWorld project+    #1600, add sum [x, y] ==> x + y+    #1549, downgrade a few of the error severities to warn+3.8, released 2024-01-15+    #1552, make --git and --ignore-glob work nicely together+    #1502, fix incorrect free variable calculation in some cases+    #1555, slightly more efficient concatMap usages (e.g. pull filter out)+    #1500, suggest avoiding NonEmpty.unzip (use Functor.unzip)+*   #1544, upgrade to GHC 9.8+    #1540, correct Functor law hint, was missing brackets+3.6.1, released 2023-07-03+    Attempt to make a binary release+3.6, released 2023-06-26+    #1522, define __GLASGOW_HASKELL__ for cmdCpp+    #1519, don't suggest removing brackets that result in a parse error+    #1512, add hints to convert for [1..n] to replicateM n+    #1430, add ignore-suggestions flag+    #1517, support NO_COLOR+    #1505, don't suggest redundant brackets around constraints+    #1478, Fix no warn on (x.y) by treating x.y as atom+    #1481, more hints about concat/concatMap+    #1485, add more hints about using a Functor on a literal tuple+    #1479, add specialised not hints for notElem/notNull+    #1437, don't add/remove Monad constraints in replacements+    #1475, rules for (elem False) and (notElem True)+    #1476, generalise map-consuming rules from lists to Foldables/Traversables+    #1480, add hints about notElem and notNull+    #1482, support SARIF output+    #1470, drop support for GHC 9.0+*   #1470, move to GHC 9.6 parser+    #1449, add some more generalize hints that suggest fmap instead of map+    Never suggest concatForM_, because it doesn't exist+    #1467, and groups for warning on partial functions+    #1465, improve the timing information with -v flag+    #1454, filter Just . map f ==> map Just . mapMaybe f+    #1452, add more evaluate rules, e.g. fromJust (Just x) ==> x+    #1488, add <$>/<&> hints for Either+    #1447, make <$> hints also work on <&> (dualized)+    #1450, suggest nub/sort ==> nubSort with the extra hints+    #1451, isJust y && (x == fromJust y) ==> Just x == y+    #578, don't suggest numeric underscores for < 5 digits+    #1428, rename "Use map" hints that introduce tuple sections+    #1424, don't suggest sortOn; suggest avoiding `reverse . sort`+3.5, released 2022-09-20+    #1421, change zip/repeat to map with tuple section+    #1418, add more QuickCheck hints+    #1420, suggest use of Data.Tuple.Extra.both in the extra hints+    #1407, fix some list-comp hints that applied too broadly+    #1407, suggest [ f x | x <- [y] ] to [f y]+    #1417, add some more isAlpha/isDigit suggestions+    #1411, add some empty list equivalent to "" hints+    #1416, add hints for (== True) and other bool/section values+    #1410, remove support for building with GHC 8.10+*   #1410, always default to using ghc-parser instead of the GHC API+*   #1410, upgrade to the GHC 9.4 parse tree+    #1408, evaluate calls of map with empty/singleton lists+    #1409, add notNull hints, e.g. notNull . concat ==> any notNull+    #1406, spot list comprehension that should be lefts/rights+    #1404, add more if/then/else to min or max hints+    #1403, add last . reverse ==> head+    #1397, evaluation rules for minimum/maximum on singleton lists+3.4.1, released 2022-07-10+    #1345, add --generate-config to generate a complete config+    #1345, add --generate-summary-json+    #1377, make anyM/allM on [] produce pure, rather than return+    #1377, add a pure rule for every return variant+    #1380, add counts as comments for --default+    #1372, remove unnecessary brackets when suggesting forM_+    #1372, suggest void (forM x y) to forM_ without the void+    #1394, replace maximum [a, b] ==> max a b (and for min)+    #1393, for QuickCheck, join . elements ==> oneOf+    #1387, bypass camelCase hint for new tasty_... custom test prefix+3.4, released 2022-04-24+    #1360, make -XHaskell2010 still obey CPP pragmas+    #1368, make TH quotation bracket rule off by default+    #1367, add brackets on refactoring templates when needed+    #1348, make module restrict hints more powerful+    #1363, add more hints for <$>+    #1362, add support for language specifier GHC2021+    #1342, make module wildcards work with `within` restrictions+    #1340, include Restriction hints in splitSettings and argsSettings output+    #1330, make ignore: {} not ignore subsequent hints+    #1317, evaluating all/any/allM/anyM on simple lists+    #1303, allow more matches for modules doing `import Prelude ()`+    #1324, add createModuleExWithFixities+    #1336, warn on unused OverloadedRecordDot+    #1334, don't remove TypeApplications if there are type-level type applications+    #1332, suggest using iterate instead of scanl/foldl+    #1331, suggest using min/max instead of if+*   #1247, move to GHC 9.2+3.3.6, released 2021-12-29+    #1326, produce release binaries+3.3.5, released 2021-12-12+    #1304, support aeson-2.0+    #1309, suggest `either Left f x` becomes `f =<< x`+    #1295, suggest TemplateHaskell to TemplateHaskellQuotes if it works+    #1292, don't say redundant bracket around pattern splices+    #1289, suggest expanding tuple sections in some cases+    #1289, suggest length [1..n] ==> max 0 n+    #1279, suggest using NumericUnderscores more if it is enabled+    #1290, move reverse out of filter+3.3.4, released 2021-08-30+    #1288, fix generation of Linux binaries+3.3.3, released 2021-08-29+    #1286, compatibility with extra-1.7.10+    #114, if OverloadedLists are enabled, don't suggest list literals+3.3.2, released 2021-08-28+    #1244, add `only` restriction to modules+    #1278, make --ignore-glob patterns also ignore directories+    #1268, move nub/sort/reverse over catMaybes/lefts/rights+    #1276, fix some incorrect unused LANGUAGE warnings+    #1271, suggest foldr (<>) mempty ==> fold (not mconcat)+    #1274, make the (& f) ==> f hint apply more+    #1264, suggest eta reduction under a where+    #1266, suggest () <$ x ==> void x+    #1223, add some traverse laws+    #1254, suggest null [x] ==> False+    #1253, suggest reverse . init ==> tail . reverse+    #1253, suggest null . concat ==> all null+    #1255, suggest filter instead of list comprehension in teaching+3.3.1, released 2021-04-26+    #1221, allow restrictions to use wildcards+    #1225, treat A{} as not-atomic for bracket hints+    #1233, -XHaskell98 and -XHaskell2010 now disable extensions too+    #1226, don't warn on top-level splices with brackets+    #1230, disable LexicalNegation by default+    #1219, suggest uncurry f (a, b) ==> f a b+    #1227, remove some excess brackets generated by refactoring+3.3, released 2021-03-14+    #1212, don't suggest redundant brackets on $(x)+    #1215, suggest varE 'foo ==> [|foo|]+    #1215, allow matching on Template Haskell variables+    #1216, require apply-refact 0.9.1.0+*   #1209, switch to the GHC 9.0.1 parse tree+    Drop GHC 8.6 support+    #1206, require apply-refact 0.9.0.0 or higher+    #1205, generalize hints which were with '&' form+3.2.8, released 2021-12-27+    #1304, support aeson-2.0+    #1286, compatibility with extra-1.7.10+3.2.7, released 2021-01-16+    #1202, add missing parentheses for Avoid Lambda+    #1201, allow matching through the & operator (similar to $)+    #1196, fix removed parens with operator sections in some cases+3.2.6, released 2020-12-30+    Fixes to the release generation script+3.2.5, released 2020-12-30+    Fixes to the release generation script+3.2.4, released 2020-12-30+    #1193, add warnings for redundant flip+    #1183, allow matches where users specify unnecessary brackets+    #1177, remove suggestions for fromMaybe False/fromMaybe True+    #1176, suggest use of unzip+    #1159, spot redundant brackets due to fixities, default ignored+    #1172, suggest reusing fromLeft/fromRight+3.2.3, released 2020-11-23+    #1160, never consult the .hscolour file for color preferences+    #1171, do not refactor redundant lambda with case+    #1169, default to -A32 (doubles speed for 4 CPU)+    #1169, make -j actually use parallelism+    #1167, enable refactoring for "Use lambda"+3.2.2, released 2020-11-15+    #1166, detect more unboxed data to avoid suggesting newtype+    #1153, fix incorrect redundant bracket with @($foo)+    #1163, do not suggest "Use lambda" when there are guards+    #1160, add showIdeaANSI to show Idea values with escape codes+3.2.1, released 2020-10-15+    #1150, remove the Duplicate hint (was slow)+    #1149, allow within to use module wildcards, e.g. **.Foo+    #1141, make redundant return highlight just the return+    #1142, suggest newtype instead of data for data family instances+    #1138, show allowed fields in YAML error message+    #1131, fix potential variable capture in zipWith/repeat hint+    #1129, add hints to use const and \_ x -> x where appropriate+3.2, released 2020-09-14+    #75, make Windows 10 use color terminals+    Make sure the extension removed matches what you called it+*   #1124, make test into a flag rather than a mode, use --test+    #1073, add LHS/RHS hints to the summary+*   Remove test --proof, --quickcheck and --typecheck, --tempdir+*   #1123, delete grep mode+    #1122, show the --refactor command line with --loud+    #1120, enable refactoring for use section+    #1114, enable refactoring for redundant as-pattern+    #1116, enable refactoring for redundant section+    #1115, more TVar/TMVar hints+    #1113, suggest x >>= pure . f becomes x <&> f+    #1111, add hint for \x y -> (x,y) to (,), and for (,,)+    #1108, enable refactoring for redundant variable capture+    #1105, enable refactoring for more redundant return hints+    #1103, enable refactoring for Redundant void+    #1083, add hints for mempty as a function+    #1097, enable refactoring for more avoid lambda hints+    #1094, error on `-XFoo` if `Foo` is not a known extension+    #1090, improve --verbose to print more information+    #1085, support eta-reduce refactoring+    #780, ignore dist and dist-newstyle directories+    #1076, fix -XNoCpp and CPP around LANGUAGE extensions+    #1077, warn on unused StandaloneKindSignatures+    #1070, warn on unused ImportQualifiedPost+    #1067, require apply-refact 0.8.1.0 (fixes lots of bugs)+    #1064, don't remove OverloadedLists if there is a []+3.1.6, released 2020-06-24+    #1062, make sure matching inserts brackets if required+    #1058, weaken the self-definition check to match more things+    #1060, suggest [] ++ x and [] ++ x to x+3.1.5, released 2020-06-19+    #1049, suggest or/and from True `elem` xs and False `notElem` xs+    #1055, avoid incorrect hints with nested (.)'s+    #1054, make isLitString work again+    #1038, make -XNoTemplateHaskell imply -XNoTemplateHaskellQuotes+    #970, require an arg to suggest fromMaybe True ==> (Just True ==)+    #1047, suggest pushing take outside zip+    #1041, fix language/pragma ordering in refactor+    #1040, fix refactoring for "Avoid lambda"+    #1042, fix redundant lambda refactoring+    #1039, don't suggest move map inside list comp repeatedly+    #1035, fix refactoring for "Use fewer imports" in some cases+    #1036, disable refactoring for Use camelCase+    #766, match quasi quotes properly in rules+    Ignore [Char] to String hints by default+    #1034, remove suggestions to use heirarchical module names+    #1032, fix refactoring for "Use :"+    #1028, add hints around sequenceA/traverse+    #1027, pass enabled and disabled extensions to apply-refact+    #1024, make the redundant bracket hints cover just the bracket+    #1024, make redundant $ display more context on the command line+    Suggest removing OverloadedLabels if there are no labels+    #367, suggest removing OverloadedLists if there are no lists+    #1023, speed up checking on large files (up to 12%)+3.1.4, released 2020-05-31+    #1018, stop --cross being quadratic+    #1019, more rules suggesting even/odd+3.1.3, released 2020-05-25+    #1016, check scopes of restricted functions+3.1.2, released 2020-05-24+    #1014, don't error on empty do blocks+    #1008, make redundant do ignored by default+    #1012, add CodeWorld hints around pictures+    #1003, enable refactoring for (v1 . v2) <$> v3+    #1002, warn on unused NumericUnderscores+3.1.1, released 2020-05-13+    #993, deal with infix declarations in the module they occur+    #993, make createModuleEx use the default HLint fixities+    #995, add unpackSrcSpan to the API+3.1, released 2020-05-07+    #979, suggest removing flip only for simple final variables+    #978, do is not redundant with non-decreasing indentation+    #969, wrong redundant bracket suggestion with BlockArguments+    #970, detect redundant sections, (a +) b ==> a + b+*   #974, split ParseFlags.extensions into enabled/disabled+    #971, add support for -XNoFoo command line flags+    #976, run refactor even if no hints+    #971, add support for NoFoo language pragmas+3.0.4, released 2020-05-03+    #968, fail on all parse errors+    #967, enable TypeApplications by default+3.0.3, released 2020-05-03+    #965, fix incorrect avoid lambda suggestion+3.0.2, released 2020-05-03+    #963, don't generate use-section hints for tuples+    #745, fix up free variables for A{x}, fixes list comp hints+3.0.1, released 2020-05-02+    #961, don't crash on non-extension LANGUAGE pragmas, e.g. Safe+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+    #859, suggest regular if instead of a simple multi-way if+    #860, improve the sortBy/sortOn hints+    #862, only suggest TupleSections for 2-tuples once+    #854, add more generalise-for-conciseness hints for Either/Maybe+    #852, change maybe to fromMaybe, when the function is duplicated+    #851, add a rule for maybe Nothing Just+2.2.10, released 2020-02-02+    #846, add splitAt warnings+    #774, don't warn about 'Redundant compare' in == and /=+2.2.9, released 2020-01-27+    Add any/map and all/map fusion hints+    #837, don't warn about redundant do for BlockArguments+    #842, fix parsing of <% operators in hlint.yaml files+    #839, match hints inside instances+    #833, UnboxedTuples can be necessary from newtype deriving+    #817, add the ability to blacklist identifiers from a module+    #834, move not out of any and all+2.2.8, released 2020-01-22+    #802, suggest lambda instead of lambda-case for single alts+    #811, add some foldMap/map hints+    #822, generalise the map/zipWith hint+    #824, embed HLint data files using TemplateHaskell+    #826, remove curry/uncurry on lambdas+    #820, make some hints work in more situations+    Reenable PackageImport unused extension detectection+    #821, warn on unless/not+    #821, avoid curry/uncurry and vice versa+    #819, fix a lot of bifunctor hints+    #812, add some rules for generalised and/or/any/all+2.2.7, released 2020-01-11+    #818, fix incorrect unused LANGUAGE BangPatterns hint+2.2.6, released 2020-01-09+    #813, remove any/all with const predicates+    Allow haskell-src-exts-1.23+    #814, suggest find instead of listToMaybe/filter+    Allow ghc-lib-parser-8.8.*+2.2.5, released 2019-12-06+    #803, allow newer ghc-lib-8.8.1+    #792, note that reverse/sort changes sort stability+    #793, don't incorrectly suggest foldr+2.2.4, released 2019-11-02+    Allow haskell-src-exts-1.22+    #788, give less redundant context on unused variable capture+    #334, add --ignore=glob flag+2.2.3, released 2019-09-29+    #766, turn on more extensions when parsing config files+    #255, don't match variables with type application+    Switch to ghc-parser-8.8.1+    Slightly restrict the replace case with fromMaybe hint+    #701, add hints for replacing case with maybe+    #724, suggest Data.Bifunctor in some places+    #725, allow custom message for restricted items+2.2.2, released 2019-07-23+    #716, upgrade to ghc-lib-parser 8.8.0.20190723+2.2.1, released 2019-07-22+    #713, make sure -XNoPatternSynonyms works (fix regression)+    #700, add some Monoid and Alternative hints+    Add createModuleEx to the API+    #698, don't suggest a replacement for DerivingStrategies+2.2, released 2019-06-26+*   Remove functions and make some things abstract in HLint3 API 2.1.26, released 2019-06-26     Make sure unknown extensions don't cause errors 2.1.25, released 2019-06-26
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2019.+Copyright Neil Mitchell 2006-2025. All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,22 +1,27 @@-# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Linux build status](https://img.shields.io/travis/ndmitchell/hlint/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hlint) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/hlint/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hlint)+# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Build status](https://img.shields.io/github/actions/workflow/status/ndmitchell/hlint/ci.yml?branch=master)](https://github.com/ndmitchell/hlint/actions)  HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows: -* [Installing and running HLint](#installing-and-running-hlint)-* [FAQ](#faq)-* [Customizing the hints](#customizing-the-hints)-* [Hacking HLint](#hacking-hlint)+* [Installing and running HLint](./README.md#installing-and-running-hlint)+* [FAQ](./README.md#faq)+* [Customizing the hints](./README.md#customizing-the-hints)+* [Hacking HLint](./README.md#hacking-hlint)  ### Bugs and limitations  Bugs can be reported [on the bug tracker](https://github.com/ndmitchell/hlint/issues). There are some issues that I do not intend to fix: -* 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.+* 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. This decision is deliberate, allowing HLint to parallelise and be used incrementally on code that may not type-check. If fixities are required to parse the code properly, they [can be supplied](./README.md#why-doesnt-hlint-know-the-fixity-for-my-custom--operator). * 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.+* Some transformed programs may require [additional type signatures](https://stackoverflow.com/questions/16402942/how-can-eta-reduction-of-a-well-typed-function-result-in-a-type-error/), particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. In rare cases, there might be [nowhere to write](https://stackoverflow.com/questions/19758828/eta-reduce-is-not-always-held-in-haskell) the required type signature.+* 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.+* Some hints, like `Use const`, don't work for non-lifted (i.e. unlifted and unboxed) types.+* Some language extensions like `Strict` can cause certain hints (e.g. eta reduction) to be incorrect.  ## Installing and running HLint @@ -52,6 +57,8 @@  The first hint is marked as an warning, because using `concatMap` in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a suggestion include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library. +Any configuration can be done via [.hlint.yaml](./README.md#customizing-the-hints) file. Any other file name, such as `.hlint.yml`, can only be used explicitly with the `--hint=FILE` option.+ **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations.  ### Suggested usage@@ -60,7 +67,7 @@  1. Initially, run `hlint . --report` to generate `report.html` containing a list of all issues HLint has found. Fix those you think are worth fixing and keep repeating. 1. Once you are happy, run `hlint . --default > .hlint.yaml`, which will generate a settings file ignoring all the hints currently outstanding. Over time you may wish to edit the list.-1. For larger projects, add [custom hints or rules](#customizing-the-hints).+1. For larger projects, add [custom hints or rules](./README.md#customizing-the-hints).  Most hints are intended to be a good idea in most circumstances, but not universally - judgement is required. When contributing to someone else's project, HLint can identify pieces of code to look at, but only make changes you consider improvements - not merely to adhere to HLint rules. @@ -81,36 +88,25 @@ HLint is integrated into lots of places:  * Lots of editors have HLint plugins (quite a few have more than one HLint plugin).-* HLint is part of the multiple editor plugins [ghc-mod](https://hackage.haskell.org/package/ghc-mod) and [Intero](https://github.com/commercialhaskell/intero).+* HLint is part of the multiple Haskell IDEs, [haskell-language-server](https://github.com/haskell/haskell-language-server), [ghc-mod](https://hackage.haskell.org/package/ghc-mod) and [Intero](https://github.com/commercialhaskell/intero). * [HLint Source Plugin](https://github.com/ocharles/hlint-source-plugin) makes HLint available as a GHC plugin.+* [Splint](https://github.com/tfausak/splint) is another source plugin that doesn't require reparsing the GHC source if you are on the latest GHC version. * [Code Climate](https://docs.codeclimate.com/v1.0/docs/hlint) is a CI for analysis which integrates HLint. * [Danger](http://allocinit.io/haskell/danger-and-hlint/) can be used to automatically comment on pull requests with HLint suggestions. * [Restyled](https://restyled.io) includes an HLint Restyler to automatically run `hlint --refactor` on files changed in GitHub Pull Requests.-* [lpaste](http://lpaste.net/) integrates with HLint - suggestions are shown at the bottom. * [hlint-test](https://hackage.haskell.org/package/hlint-test) helps you write a small test runner with HLint.+* [hint-man](https://github.com/apps/hint-man) automatically submits reviews to opened pull requests in your repositories with inline hints.+* [CircleCI](https://circleci.com/orbs/registry/orb/haskell-works/hlint) has a plugin to run HLint more easily.+* [haskell/actions](https://github.com/haskell/actions) has `hlint-setup` and `hlint-run` actions for GitHub.+* [haskell-actions/hlint-scan](https://github.com/haskell-actions/hlint-scan) is a GitHub action using HLint for [code scanning](https://docs.github.com/en/code-security/code-scanning/automatically-scanning-your-code-for-vulnerabilities-and-errors/about-code-scanning).  ### Automatically Applying Hints -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-[`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-suggestions.--Additional configuration can be passed to `refactor` with the-`--refactor-options` flag. Some useful flags include `-i` which replaces the-original file and `-s` which asks for confirmation before performing a hint.--An alternative location for `refactor` can be specified with the-`--with-refactor` flag.+HLint can automatically apply some suggestions using the `--refactor` flag. If passed, instead of printing out the hints, HLint will output the refactored file on stdout. For `--refactor` to work it is necessary to have the `refactor` executable from the [`apply-refact`](https://github.com/mpickering/apply-refact) package on your `$PATH`. HLint uses that tool to perform the refactoring. -Simple bindings for [vim](https://github.com/mpickering/hlint-refactor-vim),-[emacs](https://github.com/mpickering/hlint-refactor-mode) and [atom](https://github.com/mpickering/hlint-refactor-atom) are provided.+When using `--refactor` you can pass additional options to the `refactor` binary using `--refactor-options` flag. Some useful flags include `-i` (which replaces the original file) and `-s` (which asks for confirmation before performing a hint). The `--with-refactor` flag can be used to specify an alternative location for the `refactor` binary. Simple bindings for [Vim](https://github.com/mpickering/hlint-refactor-vim), [Emacs](https://github.com/mpickering/hlint-refactor-mode) and [Atom](https://github.com/mpickering/hlint-refactor-atom) are available. -There are no plans to support the duplication nor the renaming hints.+While the `--refactor` flag is useful, not all hints support refactoring. See [hints.md](hints.md) for which hints don't support refactoring.  ### Reports @@ -118,7 +114,7 @@  ### Language Extensions -HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Individual extensions can be enabled or disabled with, for instance, `-XArrows`, or `-XNoMagicHash`. The flag `-XHaskell2010` selects Haskell 2010 compatibility. You can also pass them via `.hlint.yaml` file. For example: `- arguments: [-XQuasiQuotes]`.+HLint enables most Haskell extensions, disabling only those which steal too much syntax (e.g. Arrows, TransformListComp and TypeApplications). Individual extensions can be enabled or disabled with, for instance, `-XArrows`, or `-XNoMagicHash`. The flag `-XHaskell2010` selects Haskell 2010 compatibility. You can also pass them via `.hlint.yaml` file. For example: `- arguments: [-XArrows]`.  ### Emacs Integration @@ -150,36 +146,13 @@  ## FAQ -### Why are hints not applied recursively?--Consider:--```haskell-foo xs = concat (map op xs)-```--This will suggest eta reduction to `concat . map op`, and then after making that change and running HLint again, will suggest use of `concatMap`. Many people wonder why HLint doesn't directly suggest `concatMap op`. There are a number of reasons:--* HLint aims to both improve code, and to teach the author better style. Doing modifications individually helps this process.-* Sometimes the steps are reasonably complex, by automatically composing them the user may become confused.-* Sometimes HLint gets transformations wrong. If suggestions are applied recursively, one error will cascade.-* Some people only make use of some of the suggestions. In the above example using concatMap is a good idea, but sometimes eta reduction isn't. By suggesting them separately, people can pick and choose.-* Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing.-* Consider `f $ (a b)`. There are two valid hints, either remove the $ or remove the brackets, but only one can be applied.+### Usage -### Why doesn't the compiler automatically apply the optimisations?+#### Why doesn't the compiler automatically apply the optimisations?  HLint doesn't suggest optimisations, it suggests code improvements - the intention is to make the code simpler, rather than making the code perform faster. The [GHC compiler](http://haskell.org/ghc/) automatically applies many of the rules suggested by HLint, so HLint suggestions will rarely improve performance. -### Why doesn't HLint know the fixity for my custom !@%$ operator?--HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a `.hlint.yaml` file as `- fixity: "infixr 5 !@%$"`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.--### Which hints are used?--HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. If you pass any `--with` hint you will need to explicitly add any `--hint` flags required.--### Why do I sometimes get a "Note" with my hint?+#### Why do I sometimes get a "Note" with my hint?  Most hints are perfect substitutions, and these are displayed without any notes. However, some hints change the semantics of your program - typically in irrelevant ways - but HLint shows a warning note. HLint does not warn when assuming typeclass laws (such as `==` being symmetric). Some notes you may see include: @@ -187,7 +160,7 @@ * __Decreases laziness__ - for example `(fst a, snd a)` suggests `a` including this note. On evaluation the new code will raise an error if a is an error, while the old code would produce a pair containing two error values. Only a small number of hints decrease laziness, and anyone relying on the laziness of the original code would be advised to include a comment. * __Removes error__ - for example `foldr1 (&&)` suggests `and` including the note `Removes error on []`. The new code will produce `True` on the empty list, while the old code would raise an error. Unless you are relying on the exception thrown by the empty list, this hint is safe - and if you do rely on the exception, you would be advised to add a comment. -### What is the difference between error/warning/suggestion?+#### What is the difference between error/warning/suggestion?  Every hint has a severity level: @@ -197,8 +170,80 @@  The difference between warning and suggestion is one of personal taste, typically my personal taste. If you already have a well developed sense of Haskell style, you should ignore the difference. If you are a beginner Haskell programmer you may wish to focus on warning hints before suggestion hints. -### Is it possible to use pragma annotations in code that is read by `ghci` (conflicts with `OverloadedStrings`)?+#### Why do I get a parse error? +HLint enables/disables a set of extensions designed to allow as many files to parse as possible, but sometimes you'll need to enable an additional extension (e.g. Arrows, QuasiQuotes, ...), or disable some (e.g. MagicHash) to enable your code to parse.++You can enable extensions by specifying additional command line arguments in [.hlint.yaml](./README.md#customizing-the-hints), e.g.: `- arguments: [-XQuasiQuotes]`.++#### How do I only run hlint on changed files?++If you're using git, it may be helpful to only run hlint on changed files. This can be a considerable speedup on very large codebases.++```bash+{ git diff --diff-filter=d --name-only $(git merge-base HEAD origin/master) -- "***.hs" && git ls-files -o --exclude-standard -- "***.hs"; } | xargs hlint+```++Because hlint's `--refactor` option only works when you pass a single file, this approach is also helpful to enable refactoring many files in a single command:++```bash+{ git diff --diff-filter=d --name-only $(git merge-base HEAD origin/master) -- "***.hs" && git ls-files -o --exclude-standard -- "***.hs"; } | xargs -I file hlint file --refactor --refactor-options="--inplace --step"+```++### Configuration++#### Why doesn't HLint know the fixity for my custom !@%$ operator?++HLint knows the fixities for all the operators in the base library, as well as operators whose fixities are declared in the module being linted, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file named `.hlint.yaml` with the syntax `- fixity: "infixr 5 !@%$"`. You can also use `--find` to automatically produce a list of fixity declarations in a file.++#### Which hints are ignored?++Some hints are off-by-default. Some are ignored by the configuration settings. To see all hints pass `--show`. This feature is often useful in conjunction with `--report` which shows the hints in an interactive web page, allowing them to be browsed broken down by hint.++#### Which hints are used?++HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`.++#### Are there any extra hints available?++There are a few groups of hints that are shipped with HLint, but disabled by default. These are:++* `future`, which suggests switching `return` for `pure`.+* `extra`, which suggests replacements which introduce a dependency on the [`extra` library](https://hackage.haskell.org/package/extra).+* `use-lens`, which suggests replacements which introduce a dependency on the [`lens` library](https://hackage.haskell.org/package/lens).+* `use-th-quotes`, which suggests using `[| x |]` where possible.+* `generalise`, which suggests more generic methods, e.g. `fmap` instead of `map`.+* `generalise-for-conciseness`, which suggests more generic methods, but only when they are shorter, e.g. `maybe True` becomes `all`.+* `dollar` which suggests `a $ b $ c` is replaced with `a . b $ c`.+* `teaching` which encourages a simple beginner friendly style, learning about related functions.++These can be enabled by passing `--with-group=future` or adding the following to your `.hlint.yaml` file:++```yaml+- group: {name: future, enabled: true}+```++### Design++#### Why are hints not applied recursively?++Consider:++```haskell+foo xs = concat (map op xs)+```++This will suggest eta reduction to `concat . map op`, and then after making that change and running HLint again, will suggest use of `concatMap`. Many people wonder why HLint doesn't directly suggest `concatMap op`. There are a number of reasons:++* HLint aims to both improve code, and to teach the author better style. Doing modifications individually helps this process.+* Sometimes the steps are reasonably complex, by automatically composing them the user may become confused.+* Sometimes HLint gets transformations wrong. If suggestions are applied recursively, one error will cascade.+* Some people only make use of some of the suggestions. In the above example using concatMap is a good idea, but sometimes eta reduction isn't. By suggesting them separately, people can pick and choose.+* Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing.+* Consider `f $ (a b)`. There are two valid hints, either remove the $ or remove the brackets, but only one can be applied.++#### Is it possible to use pragma annotations in code that is read by `ghci` (conflicts with `OverloadedStrings`)?+ Short answer: yes, it is!  If the language extension `OverloadedStrings` is enabled, `ghci` may however report error messages such as:@@ -224,28 +269,52 @@ hlint --default > .hlint.yaml ``` -This default configuration contains lots of examples, including:+This default configuration shows lots of examples (as `# comments`) of how to: -* Adding command line arguments to all runs, e.g. `--color` or `-XNoMagicHash`.-* Ignoring certain hints, perhaps within certain modules/functions.-* Restricting use of GHC flags/extensions/functions, e.g. banning `Arrows` and `unsafePerformIO`.-* Adding additional project-specific hints.+* Add command line arguments to all runs, e.g. `--color` or `-XNoMagicHash`.+* Ignore certain hints, perhaps within certain modules/functions.+* Restrict the use of GHC flags/extensions/functions, e.g. banning `Arrows` and `unsafePerformIO`.+* Add additional project-specific hints. -You can see the output of `--default` [here](https://github.com/ndmitchell/hlint/blob/master/data/default.yaml).+You can see the output of `--default` for a clean lint [here](https://github.com/ndmitchell/hlint/blob/master/data/default.yaml) but for a dirty project `--default` output includes an extra warnings section that counts and ignores any hints it finds: +  ```yaml+  # Warnings currently triggered by your code+  - ignore: {name: "Redundant $"} # 20 hints+  - ignore: {name: "Unused LANGUAGE pragma"} # 29 hints+  ```+ If you wish to use the [Dhall configuration language](https://github.com/dhall-lang/dhall-lang) to customize HLint, there [is an example](https://kowainik.github.io/posts/2018-09-09-dhall-to-hlint) and [type definition](https://github.com/kowainik/relude/blob/master/hlint/Rule.dhall). +### Finding the name of a hint++Hints are named with the string they display in their help message++For example, if hlints outputs a warning like++```+./backend/tests/api-tests/src/Main.hs:116:51: Warning: Redundant ==+Found:+  regIsEnabled rr == True+Perhaps:+  regIsEnabled rr+```++the name of the lint is `Redundant ==`.++You can use that name to refer to the lint in the configuration file and `ANN` pragmas, see the following sections.+ ### Ignoring hints  Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for suppressing certain hints. Ignore directives can either be written as pragmas in the file being analysed, or in the hint files. Examples of pragmas are:  * `{-# ANN module "HLint: ignore" #-}` or `{-# HLINT ignore #-}` or `{- HLINT ignore -}` - ignore all hints in this module (use `module` literally, not the name of the module). * `{-# ANN module "HLint: ignore Eta reduce" #-}` or `{-# HLINT ignore "Eta reduce" #-}` or `{- HLINT ignore "Eta reduce" -}` - ignore all eta reduction suggestions in this module.-* `{-# ANN myFunction "HLint: ignore" #-}` or `{-# HLINT ignore myFunction #-}` or `{- HLINT ignore myFunction -}` - don't give any hints in the function `myFunction`.-* `{-# ANN myFunction "HLint: error" #-}` or `{-# HLINT error myFunction #-}` or `{- HLINT error myFunction -}` - any hint in the function `myFunction` is an error.+* `{-# ANN myDef "HLint: ignore" #-}` or `{-# HLINT ignore myDef #-}` or `{- HLINT ignore myDef -}` - don't give any hints in the definition `myDef`. This may be combined with hint names, `{- HLINT ignore myDef "Eta reduce" -}`, to only ignore that hint in that definition.+* `{-# ANN myDef "HLint: error" #-}` or `{-# HLINT error myDef #-}` or `{- HLINT error myDef -}` - any hint in the definition `myDef` is an error. * `{-# ANN module "HLint: error Use concatMap" #-}` or `{-# HLINT error "Use concatMap" #-}` or `{- HLINT error "Use concatMap" -}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). -For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myFunction ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`.+For `ANN` pragmas it is important to put them _after_ any `import` statements. If you have the `OverloadedStrings` extension enabled you will need to give an explicit type to the annotation, e.g. `{-# ANN myDef ("HLint: ignore" :: String) #-}`. The `ANN` pragmas can also increase compile times or cause more recompilation than otherwise required, since they are evaluated by `TemplateHaskell`.  For `{-# HLINT #-}` pragmas GHC may give a warning about an unrecognised pragma, which can be suppressed with `-Wno-unrecognised-pragmas`. @@ -255,12 +324,14 @@  * `- ignore: {name: Eta reduce}` - suppress all eta reduction suggestions. * `- ignore: {name: Eta reduce, within: [MyModule1, MyModule2]}` - suppress eta reduction hints in the `MyModule1` and `MyModule2` modules.-* `- ignore: {within: MyModule.myFunction}` - don't give any hints in the function `MyModule.myFunction`.-* `- error: {within: MyModule.myFunction}` - any hint in the function `MyModule.myFunction` is an error.+* `- ignore: {within: MyModule.myDef}` - don't give any hints in the definition `MyModule.myDef`.+* `- error: {within: MyModule.myDef}` - any hint in the definition `MyModule.myDef` is an error. * `- error: {name: Use concatMap}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels).  These directives are applied in the order they are given, with later hints overriding earlier ones. +You can choose to ignore all hints with `- ignore: {}` then selectively enable the ones you want (e.g. `- warn: {name: Use const}`), but it isn't a totally smooth experience (see [#747](https://github.com/ndmitchell/hlint/issues/747) and [#748](https://github.com/ndmitchell/hlint/issues/748)).+ Finally, `hlint` defines the `__HLINT__` preprocessor definition (with value `1`), so problematic definitions (including those that don't parse) can be hidden with:  ```haskell@@ -312,22 +383,85 @@   - {name: unsafePerformIO, within: CompatLayer} ``` -This declares that the `nub` function can't be used in any modules, and thus is banned from the code. That's probably a good idea, as most people should use an alternative that isn't _O(n^2)_ (e.g. [`nubOrd`](https://hackage.haskell.org/package/extra/docs/Data-List-Extra.html#v:nubOrd)). We also whitelist where `unsafePerformIO` can occur, ensuring that there can be a centrally reviewed location to declare all such instances. Finally, we can restrict the use of modules with:+This declares that the `nub` function can't be used in any modules, and thus is banned from the code. That's probably a good idea, as most people should use an alternative that isn't _O(n^2)_ (e.g. [`nubOrd`](https://hackage.haskell.org/package/extra/docs/Data-List-Extra.html#v:nubOrd)). We also whitelist where `unsafePerformIO` can occur, ensuring that there can be a centrally reviewed location to declare all such instances. Function names can be given qualified, e.g. `Data.List.head`, but note that functions available through multiple exports (e.g. `head` is also available from `Prelude`) should be listed through all paths they are likely to be obtained, as the HLint qualified matching is unaware of re-exports. +Finally, we can restrict the use of modules with:+ ```yaml - modules:   - {name: [Data.Set, Data.HashSet], as: Set}   - {name: Control.Arrow, within: []}+  - {name: Control.Monad.State, badidents: [modify, get, put], message: "Use Control.Monad.State.Class instead"}+  - {name: Control.Exception, only: [Exception], message: "Use UnliftIO.Exception instead"} ``` -This fragment requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency. It also ensures the module `Control.Arrow` can't be used anywhere.+This fragment adds the following hints:+* Requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency+* Ensures the module `Control.Arrow` can't be used anywhere+* Prevents explicit imports of the given identifiers from `Control.Monad.State` (e.g. to prevent people from importing reexported identifiers).+* Prevents all imports from `Control.Exception`, except `Exception` +You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`).++Other options are available:++- `asRequired`: boolean.++  If true, `as` alias is required. Ignored if `as` is empty.+- `importStyle`: one of `'qualified'`, `'unqualified'`, `'explicit'`,+  `'explicitOrQualified'`, `'unrestricted'`.++  The preferred import style.++  `explicitOrQualified` accepts both `import Foo (a,b,c)` and `import qualified Foo`, but not `import Foo` or `import Foo hiding (x)`.++  `explicit` is basically the same, but doesn't accept `import qualified`.++  `qualified` and `unqualified` do not care about the import list at all.+- `qualifiedStyle`: either `'pre'`, `'post'` or `'unrestricted'`; how should the module be qualified? This option also affects how suggestions are formatted.++For example:++```yaml+- modules:+  - {name: [Data.Set, Data.HashSet], as: Set, asRequired: true}+  - {name: Debug, importStyle: explicitOrQualified}+  - {name: Unsafe, importStyle: qualified, qualifiedStyle: post, as: Unsafe}+  - {name: Prelude, importStyle: unqualified}+```++This:+* Requires `Data.Set` and `Data.HashSet` to be imported with alias `Set`; if imported without alias, a warning is generated.+* Says that `Debug` must be imported either qualified with post-qualification, i.e. `import Debug qualified`, or with an explicit import list, e.g. `Debug (debugPrint)`.+* Requires that `Unsafe` must always be imported qualified, and can't be aliased.+* Forbids `import qualified Prelude` and `import Prelude qualified` (with or without explicit import list).++You can match on module names using [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards. Module names are treated like file paths, except that periods in module names are like directory separators in file paths. So `**.*Spec` will match `Spec`, `PreludeSpec`, `Data.ListSpec`, and many more. But `*Spec` won't match `Data.ListSpec` because of the separator. See [the filepattern library](https://hackage.haskell.org/package/filepattern) for a more thorough description of the matching.++Restrictions are unified between wildcard and specific matches. With `asRequired`, `importStyle` and `qualifiedStyle` fields, the more specific option takes precedence. The list fields are merged. With multiple wildcard matches, the precedence between them is not guaranteed (but in practice, names are sorted in the reverse lexicograpic order, and the first one wins -- which hopefully means the more specific one more often than not)++If the same module is specified multiple times, for `asRequired`, `importStyle`+and `qualifiedStyle` fields, only the first definition will take effect.++```yaml+- modules:+  - {name: [Data.Map, Data.Map.*], as: Map}+  - {name: Test.Hspec, within: **.*Spec }+  - {name: '**', qualifiedStyle: post}+```+ ## Hacking HLint -Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). You can run the tests either from within a `ghci` session by typing `:test` or by running the standalone binary's tests via `cabal run hlint test` or `stack init && stack run hlint test`.+Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). -New tests for individual hints can be added directly to source and hint files by adding annotations bracketed in `<TEST></TEST>` code comment blocks. As some examples:+### How to run tests +You can run the tests either from within a `ghci` session by typing `:test` or by running the standalone binary's tests via `cabal run -- hlint --test` or `stack run -- hlint --test`. After changing hints, you will need to regenerate the [hints.md](hints.md) file with `hlint --generate-summary`.++### How to add tests++New tests for individual hints can be added directly to source and hint files by adding annotations bracketed in `<TEST></TEST>` code comment blocks. Here are some examples:+ ```haskell {-     Tests to check the zipFrom hint works@@ -342,6 +476,16 @@  The general syntax is `lhs -- rhs` with `lhs` being the expression you expect to be rewritten as `rhs`. The absence of `rhs` means you expect no hints to fire. In addition `???` lets you assert a warning without a particular suggestion, while `@` tags require a specific severity -- both these features are used less commonly. +### Printing abstract syntax++Getting started on problems in HLint often means wanting to inspect a GHC parse tree to get a sense of what it looks like (to see how to match on it for example). Given a source program `Foo.hs` (say), you can get GHC to print a textual representation of `Foo`'s AST via the `-ddump-parsed-ast` flag e.g. `ghc -fforce-recomp -ddump-parsed-ast -c Foo.hs`.++When you have an [`HsSyn`](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/hs-syn-type) term in your program, it's quite common to want to print it (e.g. via `Debug.Trace.trace`). Types in `HsSyn` aren't in [`Show`](https://hoogle.haskell.org/?hoogle=Show). Not all types in `HsSyn` are [`Outputable`](https://hoogle.haskell.org/?hoogle=Outputable) but when they are you can call `ppr` to get `SDoc`s. This idiom is common enough that there exists [`unsafePrettyPrint`](https://hackage.haskell.org/package/ghc-lib-parser-ex-8.10.0.16/docs/Language-Haskell-GhclibParserEx-GHC-Utils-Outputable.html#v:unsafePrettyPrint). The function [`showAstData`](https://hoogle.haskell.org/?hoogle=showAstData) can be called on any `HsSyn` term to get output like with the `dump-parsed-ast` flag. The `showAstData` approach is preferable to `ppr` when both choices exist in that two ASTs that differ only in fixity arrangements will render differently with the former.++### Generating the hints summary++The hints summary is an auto-generated list of hlint's builtin hints. This can be generated with `hlint --generate-summary`, which will output the summary to `hints.md`.+ ### Acknowledgements -This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.+Many improvements to this program have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.
data/HLint_QuickCheck.hs view
@@ -102,7 +102,6 @@         Right v -> Just v  _noParen_ = id-_eval_ = id  withMain :: IO () -> IO () withMain act = do
data/HLint_TypeCheck.hs view
@@ -6,7 +6,6 @@ (==>) = undefined  _noParen_ = id-_eval_ = id   ---------------------------------------------------------------------
data/Test.hs view
@@ -46,7 +46,7 @@ warn "noop" = a ? 0 ==> a  {--<TEST>+<--! TEST (temporarily disabled see issue https://github.com/ndmitchell/hlint/issues/809) !--> main = readFile "foo" >>= putStr            \   -- bad
data/default.yaml view
@@ -34,6 +34,12 @@ # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} +# The hints are named by the string they display in warning messages.+# For example, if you see a warning starting like+#+# Main.hs:116:51: Warning: Redundant ==+#+# You can refer to that hint with `{name: Redundant ==}` (see below).  # Turn on hints that are off by default #@@ -45,6 +51,9 @@ # # Generalise map to fmap, ++ to <> # - group: {name: generalise, enabled: true}+#+# Warn on use of partial functions+# - group: {name: partial, enabled: true}   # Ignore some builtin hints
+ data/do-block.yaml view
@@ -0,0 +1,2 @@+- ignore: { }+- warn: {lhs: "case m of Just x -> y; Nothing -> Nothing", rhs: "do x <- m; y"}
+ data/hintrule-implies-classify.yaml view
@@ -0,0 +1,2 @@+- ignore: { }+- warn: {lhs: mapM, rhs: traverse}
+ data/hlint-restrict-extensions.yaml view
@@ -0,0 +1,3 @@+- extensions:+  - {name: DeriveFunctor, within: []}+  - {name: DeriveTraversable, within: [], message: "Custom message"}
data/hlint.yaml view
@@ -6,35 +6,41 @@ - package:     name: base     modules:-    - import Prelude+    - import Control.Applicative     - import Control.Arrow+    - import Control.Concurrent.Chan     - import Control.Exception+    - import Control.Exception.Base     - import Control.Monad     - import Control.Monad.Trans.State-    - import qualified Data.Foldable+    - import Data.Bifunctor+    - import Data.Char+    - import Data.Either+    - import Data.Fixed     - import Data.Foldable(asum, sequenceA_, traverse_, for_)-    - import Data.Traversable(traverse, for)-    - import Control.Applicative     - import Data.Function     - import Data.Int-    - import Data.Char     - import Data.List as Data.List     - import Data.List as X+    - import Data.List.NonEmpty     - import Data.Maybe     - import Data.Monoid+    - import Data.Ratio+    - import Data.Traversable(traverse, for)+    - import Numeric+    - import Prelude+    - import System.Exit     - import System.IO-    - import Control.Concurrent.Chan     - import System.Mem.Weak-    - import Control.Exception.Base-    - import System.Exit-    - import Data.Either-    - import Numeric+    - import Text.Read+    - import qualified Data.Foldable      - import IO as System.IO     - import List as Data.List     - import Maybe as Data.Maybe     - import Monad as Control.Monad     - import Char as Data.Char+    - import Language.Haskell.TH as TH  - package:     name: lens@@ -49,6 +55,16 @@     - import Data.Attoparsec.Text     - import Data.Attoparsec.ByteString +- package:+    name: quickcheck+    modules:+    - import Test.QuickCheck++- package:+    name: codeworld-api+    modules:+    - import CodeWorld+ - group:     name: default     enabled: true@@ -59,6 +75,8 @@     # I/O      - warn: {lhs: putStrLn (show x), rhs: print x}+    - warn: {lhs: putStr (x ++ "\n"), rhs: putStrLn x}+    - warn: {lhs: putStr (x ++ y ++ "\n"), rhs: putStrLn (x ++ y)}     - warn: {lhs: mapM_ putChar, rhs: putStr}     - warn: {lhs: hGetChar stdin, rhs: getChar}     - warn: {lhs: hGetLine stdin, rhs: getLine}@@ -97,18 +115,28 @@     - warn: {lhs: last (sort x), rhs: maximum x}     - warn: {lhs: head (sortBy f x), rhs: minimumBy f x, side: isCompare f}     - warn: {lhs: last (sortBy f x), rhs: maximumBy f x, side: isCompare f}-    - warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f}-    - warn: {lhs: sortBy (comparing (flip f)), rhs: sortOn (Down . f)}-    - warn: {lhs: sortBy (comparing f), rhs: sortOn f}-    - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse}-    - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse}+    - warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f, note: Stabilizes sort order}+    - warn: {lhs: sortBy (flip (comparing f)), rhs: sortBy (comparing (Data.Ord.Down . f))}+    - 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: sortBy (comparing 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}+    - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Use on once}+    - warn: {lhs: if a >= b then a else b, rhs: max a b}+    - warn: {lhs: if a >= b then b else a, rhs: min a b}+    - warn: {lhs: if a > b then a else b, rhs: max a b}+    - warn: {lhs: if a > b then b else a, rhs: min a b}+    - warn: {lhs: if a <= b then a else b, rhs: min a b}+    - warn: {lhs: if a <= b then b else a, rhs: max a b}+    - warn: {lhs: if a < b then a else b, rhs: min a b}+    - warn: {lhs: if a < b then b else a, rhs: max a b}+    - warn: {lhs: "maximum [a, b]", rhs: max a b}+    - warn: {lhs: "minimum [a, b]", rhs: min a b}       # READ/SHOW      - warn: {lhs: showsPrec 0 x "", rhs: show x}+    - warn: {lhs: "showsPrec 0 x []", rhs: show x}     - warn: {lhs: readsPrec 0, rhs: reads}     - warn: {lhs: showsPrec 0, rhs: shows}     - hint: {lhs: showIntAtBase 16 intToDigit, rhs: showHex}@@ -117,20 +145,27 @@     # LIST      - warn: {lhs: concat (map f x), rhs: concatMap f x}+    - warn: {lhs: concat (f <$> x), rhs: concatMap f x}+    - warn: {lhs: concat (x <&> f), rhs: concatMap f x}     - warn: {lhs: concat (fmap f x), rhs: concatMap f x}     - hint: {lhs: "concat [a, b]", rhs: a ++ b}+    - hint: {lhs: "sum [a, b]", rhs: a + b, name: "Use + directly"}     - hint: {lhs: map f (map g x), rhs: map (f . g) x, name: Use map once}     - hint: {lhs: concatMap f (map g x), rhs: concatMap (f . g) x, name: Fuse concatMap/map}     - hint: {lhs: x !! 0, rhs: head x}     - warn: {lhs: take n (repeat x), rhs: replicate n x}     - warn: {lhs: map f (replicate n x), rhs: replicate n (f x)}     - warn: {lhs: map f (repeat x), rhs: repeat (f x)}+    - warn: {lhs: concatMap f (repeat x), rhs: cycle (f x)}+    - warn: {lhs: concat (repeat x), rhs: cycle x}     - warn: {lhs: "cycle [x]", rhs: repeat x}     - warn: {lhs: head (reverse x), rhs: last x}+    - warn: {lhs: last (reverse x), rhs: head x, note: IncreasesLaziness}     - warn: {lhs: head (drop n x), rhs: x !! n, side: isNat n}     - warn: {lhs: head (drop n x), rhs: x !! max 0 n, side: not (isNat n) && not (isNeg n)}+    - warn: {lhs: reverse (init x), rhs: tail (reverse x)}     - warn: {lhs: reverse (tail (reverse x)), rhs: init x, note: IncreasesLaziness}-    - warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Avoid reverse}+    - warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Redundant reverse}     - warn: {lhs: isPrefixOf (reverse x) (reverse y), rhs: isSuffixOf x y}     - warn: {lhs: "foldr (++) []", rhs: concat}     - warn: {lhs: foldr (++) "", rhs: concat}@@ -141,20 +176,29 @@     - 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}+    - warn: {lhs: span (notElem x), rhs: break (elem x), name: Use break}+    - warn: {lhs: break (notElem x), rhs: span (elem x), name: Use span}+    - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness}     - warn: {lhs: fst (span p x), rhs: takeWhile p x}     - warn: {lhs: snd (span p x), rhs: dropWhile p x}     - warn: {lhs: fst (break p x), rhs: takeWhile (not . p) x}     - warn: {lhs: snd (break p x), rhs: dropWhile (not . p) x}+    - warn: {lhs: "(take n x, drop n x)", rhs: splitAt n x, note: DecreasesLaziness}+    - warn: {lhs: fst (splitAt p x), rhs: take p x}+    - warn: {lhs: snd (splitAt p x), rhs: drop p x}     - warn: {lhs: concatMap (++ "\n"), rhs: unlines}     - warn: {lhs: map id, rhs: id}     - warn: {lhs: concatMap id, rhs: concat}     - warn: {lhs: or (map p x), rhs: any p x}     - warn: {lhs: and (map p x), rhs: all p x}+    - warn: {lhs: any f (map g x), rhs: any (f . g) x}+    - warn: {lhs: all f (map g x), rhs: all (f . g) x}     - warn: {lhs: "zipWith (,)", rhs: zip}     - warn: {lhs: "zipWith3 (,,)", rhs: zip3}+    - hint: {lhs: map fst &&& map snd, rhs: unzip}     - hint: {lhs: length x == 0, rhs: null x, note: IncreasesLaziness}     - hint: {lhs: 0 == length x, rhs: null x, note: IncreasesLaziness}     - hint: {lhs: length x < 1, rhs: null x, note: IncreasesLaziness}@@ -163,22 +207,30 @@     - hint: {lhs: 0 >= length x, rhs: null x, note: IncreasesLaziness}     - hint: {lhs: "x == []", rhs: null x}     - hint: {lhs: "[] == x", rhs: null x}+    - hint: {lhs: all (const False), rhs: "null"}+    - hint: {lhs: any (const True) x, rhs: not (null x), name: Use null}     - hint: {lhs: length x /= 0, rhs: not (null x), note: IncreasesLaziness, name: Use null}     - hint: {lhs: 0 /= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null}     - hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"}-    - warn: {lhs: map (uncurry f) (zip x y), rhs: zipWith f x y}-    - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: isVar f}+    - 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"}+    - hint: {lhs: "concatMap f (fromMaybe [] x)", rhs: "maybe [] (concatMap f) x"}+    - hint: {lhs: "concat (fromMaybe [] x)", rhs: "maybe [] concat x"}     - warn: {lhs: not (elem x y), rhs: notElem x y}+    - warn: {lhs: not (notElem x y), rhs: elem 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)"}     - warn: {lhs: intercalate " ", rhs: unwords}     - hint: {lhs: concat (intersperse x y), rhs: intercalate x y, side: notEq x " "}     - hint: {lhs: concat (intersperse " " x), rhs: unwords x}+    - warn: {lhs: null (concat x), rhs: all null x}     - warn: {lhs: null (filter f x), rhs: not (any f x), name: Use any}     - warn: {lhs: "filter f x == []", rhs: not (any f x), name: Use any}     - warn: {lhs: "filter f x /= []", rhs: any f x}     - warn: {lhs: any id, rhs: or}     - warn: {lhs: all id, rhs: and}+    - warn: {lhs: any (not . f) x, rhs: not (all f x), name: Hoist not}+    - warn: {lhs: all (not . f) x, rhs: not (any f x), name: Hoist not}     - warn: {lhs: any ((==) a), rhs: elem a, note: ValidInstance Eq a}     - warn: {lhs: any (== a), rhs: elem a}     - warn: {lhs: any (a ==), rhs: elem a, note: ValidInstance Eq a}@@ -187,6 +239,12 @@     - warn: {lhs: all (a /=), rhs: notElem a, note: ValidInstance Eq a}     - warn: {lhs: elem True, rhs: or}     - warn: {lhs: notElem False, rhs: and}+    - warn: {lhs: True `elem` l, rhs: or l}+    - warn: {lhs: False `notElem` l, rhs: and l}+    - warn: {lhs: elem False, rhs: any not, name: Use any}+    - warn: {lhs: notElem True, rhs: all not, name: Use all}+    - warn: {lhs: False `elem` l, rhs: any not l, name: Use any}+    - warn: {lhs: True `notElem` l, rhs: all not l, name: Use all}     - warn: {lhs: findIndex ((==) a), rhs: elemIndex a}     - warn: {lhs: findIndex (a ==), rhs: elemIndex a}     - warn: {lhs: findIndex (== a), rhs: elemIndex a}@@ -196,6 +254,7 @@     - warn: {lhs: "lookup b (zip l [0..])", rhs: elemIndex b l}     - hint: {lhs: "elem x [y]", rhs: x == y, note: ValidInstance Eq a}     - hint: {lhs: "notElem x [y]", rhs: x /= y, note: ValidInstance Eq a}+    - hint: {lhs: "length [1..n]", rhs: max 0 n}     - hint: {lhs: length x >= 0, rhs: "True", name: Length always non-negative}     - hint: {lhs: 0 <= length x, rhs: "True", name: Length always non-negative}     - hint: {lhs: length x > 0, rhs: not (null x), note: IncreasesLaziness, name: Use null}@@ -206,18 +265,55 @@     - warn: {lhs: drop i x, rhs: x, side: isNegZero i, name: Drop on a non-positive}     - warn: {lhs: last (scanl f z x), rhs: foldl f z x}     - warn: {lhs: head (scanr f z x), rhs: foldr f z x}+    - warn: {lhs: "scanl (\\x _ -> a) b (replicate c d)", rhs: "take c (iterate (\\x -> a) b)"}+    - warn: {lhs: "foldl (\\x _ -> a) b [1..c]", rhs: "iterate (\\x -> a) b !! c"}     - warn: {lhs: iterate id, rhs: repeat}     - warn: {lhs: zipWith f (repeat x), rhs: map (f x)}-    - warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y}+    - warn: {lhs: zip (repeat x), rhs: "map (_noParen_ x,)", note: RequiresExtension TupleSections, name: "Use map with tuple-section"}+    - warn: {lhs: zipWith f y (repeat z), rhs: map (`f` z) y}+    - warn: {lhs: zip y (repeat z), rhs: "map (,_noParen_ z) y", note: RequiresExtension TupleSections, name: "Use map with tuple-section"}+    - warn: {lhs: listToMaybe (filter p x), rhs: find p x}+    - warn: {lhs: zip (take n x) (take n y), rhs: take n (zip x y)}+    - warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: [IncreasesLaziness, DecreasesLaziness], name: Redundant take} +    # MONOIDS++    - warn: {lhs: mempty <> x, rhs: x, name: "Monoid law, left identity"}+    - warn: {lhs: mempty `mappend` x, rhs: x, name: "Monoid law, left identity"}+    - warn: {lhs: x <> mempty, rhs: x, name: "Monoid law, right identity"}+    - warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"}+    - warn: {lhs: foldr (<>) mempty, rhs: Data.Foldable.fold}+    - warn: {lhs: foldr mappend mempty, rhs: Data.Foldable.fold}+    - warn: {lhs: mempty x, rhs: mempty, name: Evaluate}+    - warn: {lhs: x `mempty` y, rhs: mempty, name: Evaluate, note: "Make sure you didn't mean to use mappend instead of mempty"}+     # TRAVERSABLES +    - warn: {lhs: traverse pure, rhs: pure, name: "Traversable law"}+    - warn: {lhs: traverse (pure . f) x, rhs: pure (fmap f x), name: "Traversable law"}     - warn: {lhs: sequenceA (map f x), rhs: traverse f x}+    - warn: {lhs: sequenceA (f <$> x), rhs: traverse f x}+    - warn: {lhs: sequenceA (x <&> f), rhs: traverse f x}     - warn: {lhs: sequenceA (fmap f x), rhs: traverse f x}-    - warn: {lhs: sequence (fmap f x), rhs: traverse f x}     - warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x}+    - warn: {lhs: sequenceA_ (f <$> x), rhs: traverse_ f x}+    - warn: {lhs: sequenceA_ (x <&> f), rhs: traverse_ f x}     - warn: {lhs: sequenceA_ (fmap f x), rhs: traverse_ f x}     - warn: {lhs: foldMap id, rhs: fold}+    - warn: {lhs: fold (f <$> x), rhs: foldMap f x}+    - warn: {lhs: fold (x <&> f), rhs: foldMap f x}+    - warn: {lhs: fold (fmap f x), rhs: foldMap f x}+    - warn: {lhs: fold (map f x), rhs: foldMap f x}+    - warn: {lhs: foldMap f (g <$> x), rhs: foldMap (f . g) x, name: Fuse foldMap/<$>}+    - warn: {lhs: foldMap f (x <&> g), rhs: foldMap (f . g) x, name: Fuse foldMap/<&>}+    - 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}+    - warn: {lhs: traverse f (fmap g x), rhs: traverse (f . g) x, name: Fuse traverse/fmap}+    - warn: {lhs: traverse f (g <$> x), rhs: traverse (f . g) x, name: Fuse traverse/<$>}+    - warn: {lhs: traverse f (x <&> g), rhs: traverse (f . g) x, name: Fuse traverse/<&>}+    - warn: {lhs: traverse_ f (fmap g x), rhs: traverse_ (f . g) x, name: Fuse traverse_/fmap}+    - warn: {lhs: traverse_ f (g <$> x), rhs: traverse_ (f . g) x, name: Fuse traverse_/<$>}+    - warn: {lhs: traverse_ f (x <&> g), rhs: traverse_ (f . g) x, name: Fuse traverse_/<&>}      # BY @@ -233,6 +329,7 @@      # FOLDS +    - warn: {lhs: foldr  (>>) (pure ()), rhs: sequence_}     - warn: {lhs: foldr  (>>) (return ()), rhs: sequence_}     - warn: {lhs: foldr  (&&) True, rhs: and}     - warn: {lhs: foldl  (&&) True, rhs: and, note: IncreasesLaziness}@@ -260,31 +357,47 @@      - warn: {lhs: \x -> x, rhs: id}     - warn: {lhs: \x y -> x, rhs: const}+    - warn: {lhs: curry fst, rhs: const}+    - warn: {lhs: curry snd, rhs: \_ x -> x, note: "Alternatively, use const id"}+    - warn: {lhs: flip const, rhs: \_ x -> x, note: "Alternatively, use const id"}     - warn: {lhs: "\\(x,y) -> y", rhs: snd}     - warn: {lhs: "\\(x,y) -> x", rhs: fst}     - hint: {lhs: "\\x y -> f (x,y)", rhs: curry f}     - hint: {lhs: "\\(x,y) -> f x y", rhs: uncurry f, note: IncreasesLaziness}     - warn: {lhs: f (fst p) (snd p), rhs: uncurry f p}-    - warn: {lhs: ($) . f, rhs: f, name: Redundant $}+    - warn: {lhs: "uncurry (\\x y -> z)", rhs: "\\(x,y) -> z"}+    - warn: {lhs: "curry (\\(x,y) -> z)", rhs: "\\x y -> z"}+    - warn: {lhs: uncurry (curry f), rhs: f, name: Redundant curry/uncurry}+    - warn: {lhs: curry (uncurry f), rhs: f, name: Redundant curry/uncurry}+    - warn: {lhs: "uncurry f (a, b)", rhs: f a b}+    - warn: {lhs: ($) (f x), rhs: f x, name: Redundant $}     - warn: {lhs: (f $), rhs: f, name: Redundant $}-    - warn: {lhs: (Data.Function.& f), rhs: f, name: Redundant Data.Function.&}+    - warn: {lhs: (& f), rhs: f, name: Redundant &}     - hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)}         # If any isWildcard recursively then x may be used but not mentioned explicitly-    - warn: {lhs: flip f x y, rhs: f y x, side: isApp original}-    - warn: {lhs: id x, rhs: x, side: not (isTypeApp x)}+    - warn: {lhs: flip f x y, rhs: f y x, side: isApp original && isAtom y}+    - warn: {lhs: id x, rhs: x}     - warn: {lhs: id . x, rhs: x, name: Redundant id}     - warn: {lhs: x . id, rhs: x, name: Redundant id}     - warn: {lhs: "((,) x)", rhs: "(_noParen_ x,)", name: Use tuple-section, note: RequiresExtension TupleSections}     - warn: {lhs: "flip (,) x", rhs: "(,_noParen_ x)", name: Use tuple-section, note: RequiresExtension TupleSections}-    - warn: {lhs: "\\y -> (x,y)", rhs: "(x,)", name: Use tuple-section, note: RequiresExtension TupleSections}-    - warn: {lhs: "\\y -> (y,x)", rhs: "(,x)", name: Use tuple-section, note: RequiresExtension TupleSections}+    - warn: {lhs: flip (flip f), rhs: f, note: DecreasesLaziness}+    - warn: {lhs: flip f <*> g, rhs: f =<< g, name: Redundant flip}+    - warn: {lhs: g <**> flip f, rhs: g >>= f, name: Redundant flip}+    - warn: {lhs: flip f =<< g, rhs: f <*> g, name: Redundant flip}+    - warn: {lhs: g >>= flip f, rhs: g Control.Applicative.<**> f, name: Redundant flip}+    - warn: {lhs: ($ x) . f, rhs: flip f x}      # CHAR -    - warn: {lhs: a >= 'a' && a <= 'z', rhs: isAsciiLower a}-    - warn: {lhs: a >= 'A' && a <= 'Z', rhs: isAsciiUpper a}-    - warn: {lhs: a >= '0' && a <= '9', rhs: isDigit a}-    - warn: {lhs: a >= '0' && a <= '7', rhs: isOctDigit a}+    - warn: {lhs: "a >= 'a' && a <= 'z'", rhs: isAsciiLower a}+    - warn: {lhs: "'a' <= a && a <= 'z'", rhs: isAsciiLower a}+    - warn: {lhs: "a >= 'A' && a <= 'Z'", rhs: isAsciiUpper a}+    - warn: {lhs: "'A' <= a && a <= 'Z'", rhs: isAsciiUpper a}+    - warn: {lhs: "a >= '0' && a <= '9'", rhs: isDigit a}+    - warn: {lhs: "'0' <= a && a <= '9'", rhs: isDigit a}+    - warn: {lhs: "a >= '0' && a <= '7'", rhs: isOctDigit a}+    - warn: {lhs: "'0' <= a && a <= '7'", rhs: isOctDigit a}     - warn: {lhs: isLower a || isUpper a, rhs: isAlpha a}     - warn: {lhs: isUpper a || isLower a, rhs: isAlpha a} @@ -294,10 +407,18 @@     - hint: {lhs: x == False, rhs: not x, name: Redundant ==}     - warn: {lhs: True == a, rhs: a, name: Redundant ==}     - hint: {lhs: False == a, rhs: not a, name: Redundant ==}+    - hint: {lhs: (== True), rhs: id, name: Redundant ==}+    - hint: {lhs: (== False), rhs: not, name: Redundant ==}+    - hint: {lhs: (True ==), rhs: id, name: Redundant ==}+    - hint: {lhs: (False ==), rhs: not, name: Redundant ==}     - warn: {lhs: a /= True, rhs: not a, name: Redundant /=}     - hint: {lhs: a /= False, rhs: a, name: Redundant /=}     - warn: {lhs: True /= a, rhs: not a, name: Redundant /=}     - hint: {lhs: False /= a, rhs: a, name: Redundant /=}+    - hint: {lhs: (/= True), rhs: not, name: Redundant /=}+    - hint: {lhs: (/= False), rhs: id, name: Redundant /=}+    - hint: {lhs: (True /=), rhs: not, name: Redundant /=}+    - hint: {lhs: (False /=), rhs: id, name: Redundant /=}     - warn: {lhs: if a then x else x, rhs: x, note: IncreasesLaziness, name: Redundant if}     - warn: {lhs: if a then True else False, rhs: a, name: Redundant if}     - warn: {lhs: if a then False else True, rhs: not a, name: Redundant if}@@ -305,6 +426,7 @@     - warn: {lhs: if a then (if b then t else f) else f, rhs: if a && b then t else f, name: Redundant if}     - warn: {lhs: if x then True else y, rhs: x || y, side: notEq y False, name: Redundant if}     - warn: {lhs: if x then y else False, rhs: x && y, side: notEq y True, name: Redundant if}+    - warn: {lhs: if | b -> t | otherwise -> f, rhs: if b then t else f, name: Redundant multi-way if}     - hint: {lhs: "case a of {True -> t; False -> f}", rhs: if a then t else f, name: Use if}     - hint: {lhs: "case a of {False -> f; True -> t}", rhs: if a then t else f, name: Use if}     - hint: {lhs: "case a of {True -> t; _ -> f}", rhs: if a then t else f, name: Use if}@@ -318,29 +440,50 @@     - 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      - warn: {lhs: id *** g, rhs: second g}     - warn: {lhs: f *** id, rhs: first f}     - ignore: {lhs: zip (map f x) (map g x), rhs: map (f Control.Arrow.&&& g) x}-    - ignore: {lhs: "\\(x,y) -> (f x, g y)", rhs: f Control.Arrow.*** g}     - ignore: {lhs: "\\x -> (f x, g x)", rhs: f Control.Arrow.&&& g}-    - ignore: {lhs: "\\(x,y) -> (f x,y)", rhs: Control.Arrow.first f}-    - ignore: {lhs: "\\(x,y) -> (x,f y)", rhs: Control.Arrow.second f}-    - ignore: {lhs: "(f (fst x), g (snd x))", rhs: (f Control.Arrow.*** g) x}     - hint: {lhs: "(fst x, snd x)", rhs:  x, note: DecreasesLaziness, name: Redundant pair} +    # BIFUNCTOR++    - warn: {lhs: bimap id g, rhs: second g}+    - warn: {lhs: bimap f id, rhs: first f}+    - warn: {lhs: first id, rhs: id}+    - warn: {lhs: second id, rhs: id}+    - warn: {lhs: bimap id id, rhs: id}+    - warn: {lhs: first f (second g x), rhs: bimap f g x}+    - warn: {lhs: second g (first f x), rhs: bimap f g x}+    - warn: {lhs: first f (first g x), rhs: first (f . g) x}+    - warn: {lhs: second f (second g x), rhs: second (f . g) x}+    - warn: {lhs: bimap f h (bimap g i x), rhs: bimap (f . g) (h . i) x}+    - warn: {lhs: first f (bimap g h x), rhs: bimap (f . g) h x}+    - warn: {lhs: second g (bimap f h x), rhs: bimap f (g . h) x}+    - warn: {lhs: bimap f h (first g x), rhs: bimap (f . g) h x}+    - warn: {lhs: bimap f g (second h x), rhs: bimap f (g . h) x}+    - hint: {lhs: "\\(x,y) -> (f x, g y)", rhs: Data.Bifunctor.bimap f g, note: IncreasesLaziness}+    - hint: {lhs: "\\(x,y) -> (f x,y)", rhs: Data.Bifunctor.first f, note: IncreasesLaziness}+    - hint: {lhs: "\\(x,y) -> (x,f y)", rhs: Data.Bifunctor.second f, note: IncreasesLaziness}+    - hint: {lhs: "(f (fst x), g (snd x))", rhs: Data.Bifunctor.bimap f g x}+    - hint: {lhs: "(f (fst x), snd x)", rhs: Data.Bifunctor.first f x}+    - hint: {lhs: "(fst x, g (snd x))", rhs: Data.Bifunctor.second g x}+     # FUNCTOR      - warn: {lhs: fmap f (fmap g x), rhs: fmap (f . g) x, name: Functor law}-    - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x, name: Functor law}+    - warn: {lhs: f <$> (g <$> x), rhs: f . g <$> x, name: Functor law}+    - warn: {lhs: x <&> g <&> f, rhs: x <&> f . g, name: Functor law}     - warn: {lhs: fmap id, rhs: id, name: Functor law}     - warn: {lhs: id <$> x, rhs: x, name: Functor law}-    - hint: {lhs: fmap f $ x, rhs: f Control.Applicative.<$> x, side: isApp x || isAtom x}+    - warn: {lhs: x <&> id, rhs: x, name: Functor law}+    - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x}+    - hint: {lhs: fmap f $ x, rhs: f <$> x, side: isApp x || isAtom x}     - hint: {lhs: \x -> a <$> b x, rhs: fmap a . b}+    - hint: {lhs: \x -> b x <&> a, rhs: fmap a . b}     - hint: {lhs: x *> pure y, rhs: x Data.Functor.$> y}     - hint: {lhs: x *> return y, rhs: x Data.Functor.$> y}     - hint: {lhs: pure x <* y, rhs: x Data.Functor.<$ y}@@ -351,62 +494,119 @@     - hint: {lhs: x <&> const y, rhs: x Data.Functor.$> y}     - hint: {lhs: x <&> pure y, rhs: x Data.Functor.$> y}     - hint: {lhs: x <&> return y, rhs: x Data.Functor.$> y}+    - warn: {lhs: "fmap f (x,b)", rhs: "(x,f b)", name: Using fmap on tuple}+    - warn: {lhs: "f <$> (x,b)", rhs: "(x,f b)", name: Using <$> on tuple}+    - warn: {lhs: "(x,b) <&> f", rhs: "(x,f b)", name: Using <&> on tuple}+    - warn: {lhs: "fmap f (x,y,b)", rhs: "(x,y,f b)", name: Using fmap on tuple}+    - warn: {lhs: "f <$> (x,y,b)", rhs: "(x,y,f b)", name: Using <$> on tuple}+    - warn: {lhs: "(x,y,b) <&> f", rhs: "(x,y,f b)", name: Using <&> on tuple}      # APPLICATIVE -    - hint: {lhs: return x <*> y, rhs: x <$> y}     - hint: {lhs: pure x <*> y, rhs: x <$> y}+    - hint: {lhs: return x <*> y, rhs: x <$> y}     - warn: {lhs: x <* pure y, rhs: x}-    - warn: {lhs: pure x *> y, rhs: "y"}+    - warn: {lhs: x <* return y, rhs: x}+    - warn: {lhs: pure x *> y, rhs: "y", name: Redundant *>}+    - warn: {lhs: return x *> y, rhs: "y", name: Redundant *>}+    - warn: {lhs: "x <*> Nothing", rhs: "Nothing" }+    - warn: {lhs: "x <*> First Nothing", rhs: "First Nothing" }+    - warn: {lhs: "x <*> Last Nothing", rhs: "Last Nothing" }+    - warn: {lhs: "x <*> Left a", rhs: "Left a" }+    - warn: {lhs: "x <*> Ap []", rhs: "Ap []" }+    - warn: {lhs: "x <*> []", rhs: "[]" }      # MONAD +    - warn: {lhs: pure a >>= f, rhs: f a, name: "Monad law, left identity"}     - warn: {lhs: return a >>= f, rhs: f a, name: "Monad law, left identity"}+    - warn: {lhs: f =<< pure a, rhs: f a, name: "Monad law, left identity"}     - warn: {lhs: f =<< return a, rhs: f a, name: "Monad law, left identity"}+    - warn: {lhs: m >>= pure, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: m >>= return, rhs: m, name: "Monad law, right identity"}+    - warn: {lhs: pure =<< m, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: return =<< m, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: liftM, rhs: fmap}     - warn: {lhs: liftA, rhs: fmap}-    - hint: {lhs: m >>= return . f, rhs: f <$> m}+    - hint: {lhs: m >>= pure . f, rhs: m Data.Functor.<&> f}+    - hint: {lhs: m >>= return . f, rhs: m Data.Functor.<&> f}+    - hint: {lhs: pure . f =<< m, 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 pure (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}     - 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 pure (), rhs: Control.Monad.when x y, side: isAtom y}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y}+    - warn: {lhs: if x then pure () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}+    - warn: {lhs: if x then pure () else y, rhs: Control.Monad.unless x y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x y, side: isAtom y}     - warn: {lhs: sequence (map f x), rhs: mapM f x}     - warn: {lhs: sequence_ (map f x), rhs: mapM_ f x}+    - warn: {lhs: sequence (f <$> x), rhs: mapM f x}+    - warn: {lhs: sequence (x <&> f), rhs: mapM f x}     - warn: {lhs: sequence (fmap f x), rhs: mapM f x}+    - warn: {lhs: sequence_ (f <$> x), rhs: mapM_ f x}+    - warn: {lhs: sequence_ (x <&> f), rhs: mapM_ f x}     - warn: {lhs: sequence_ (fmap f x), rhs: mapM_ f x}     - hint: {lhs: flip mapM, rhs: Control.Monad.forM}     - hint: {lhs: flip mapM_, rhs: Control.Monad.forM_}     - hint: {lhs: flip forM, rhs: mapM}     - hint: {lhs: flip forM_, rhs: mapM_}     - warn: {lhs: when (not x), rhs: unless x}+    - warn: {lhs: when (notElem x y), rhs: unless (elem x y), name: Use unless}+    - warn: {lhs: unless (not x), rhs: when x}+    - warn: {lhs: unless (notElem x y), rhs: when (elem x y), name: Use when}     - warn: {lhs: x >>= id, rhs: Control.Monad.join x}     - warn: {lhs: id =<< x, rhs: Control.Monad.join x}-    - warn: {lhs: id =<< x, rhs: Control.Monad.join x}-    - warn: {lhs: id =<< x, rhs: Control.Monad.join x}     - hint: {lhs: join (f <$> x), rhs: f =<< x}+    - hint: {lhs: join (x <&> f), rhs: f =<< x}     - hint: {lhs: join (fmap f x), rhs: f =<< x}+    - hint: {lhs: a >> pure (), rhs: Control.Monad.void a, side: isAtom a || isApp a}     - hint: {lhs: a >> return (), rhs: Control.Monad.void a, side: isAtom a || isApp a}     - warn: {lhs: fmap (const ()), rhs: Control.Monad.void}     - warn: {lhs: const () <$> x, rhs: Control.Monad.void x}+    - warn: {lhs: x <&> const (), rhs: Control.Monad.void x}+    - warn: {lhs: () <$ x, rhs: Control.Monad.void x}     - warn: {lhs: flip (>=>), rhs: (<=<)}     - warn: {lhs: flip (<=<), rhs: (>=>)}     - warn: {lhs: flip (>>=), rhs: (=<<)}     - 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: liftM2 f (pure x), rhs: fmap (f x)}+    - 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 (pure x), rhs: pure (f x)}+    - warn: {lhs: fmap f (return x), rhs: return (f x)}+    - warn: {lhs: f <$> pure x, rhs: pure (f x)}+    - warn: {lhs: pure x <&> f, rhs: pure (f x)}+    - warn: {lhs: f <$> return x, rhs: return (f x)}+    - warn: {lhs: return x <&> f, 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}     - warn: {lhs: a >>= \_ -> b, rhs: a >> b}+    - warn: {lhs: m <* pure x, rhs: m}     - warn: {lhs: m <* return x, rhs: m}-    - warn: {lhs: return x *> m, rhs: m}-    - warn: {lhs: pure x >> m, rhs: m}-    - warn: {lhs: return x >> m, rhs: m}+    - warn: {lhs: pure x *> m, rhs: m, name: Redundant *>}+    - warn: {lhs: return x *> m, rhs: m, name: Redundant *>}+    - warn: {lhs: pure x >> m, rhs: m, name: Redundant >>}+    - warn: {lhs: return x >> m, rhs: m, name: Redundant >>}+    - warn: {lhs: "forM [1..n] (const f)", rhs: replicateM n f}+    - warn: {lhs: "for [1..n] (const f)", rhs: replicateM n f}+    - warn: {lhs: "forM [1..n] (\\_ -> x)", rhs: replicateM n x}+    - warn: {lhs: "for [1..n] (\\_ -> x)", rhs: replicateM n x}      # STATE MONAD @@ -415,11 +615,17 @@      # MONAD LIST +    - warn: {lhs: unzip <$> mapM f x, rhs: Control.Monad.mapAndUnzipM f x}+    - warn: {lhs: mapM f x <&> unzip, rhs: Control.Monad.mapAndUnzipM f x}     - warn: {lhs: fmap unzip (mapM f x), rhs: Control.Monad.mapAndUnzipM f x}     - warn: {lhs: sequence (zipWith f x y), rhs: Control.Monad.zipWithM f x y}     - warn: {lhs: sequence_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}     - warn: {lhs: sequence (replicate n x), rhs: Control.Monad.replicateM n x}     - warn: {lhs: sequence_ (replicate n x), rhs: Control.Monad.replicateM_ n x}+    - warn: {lhs: sequenceA (zipWith f x y), rhs: Control.Monad.zipWithM f x y}+    - warn: {lhs: sequenceA_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}+    - warn: {lhs: sequenceA (replicate n x), rhs: Control.Monad.replicateM n x}+    - warn: {lhs: sequenceA_ (replicate n x), rhs: Control.Monad.replicateM_ n x}     - warn: {lhs: mapM f (replicate n x), rhs: Control.Monad.replicateM n (f x)}     - warn: {lhs: mapM_ f (replicate n x), rhs: Control.Monad.replicateM_ n (f x)}     - warn: {lhs: mapM f (map g x), rhs: mapM (f . g) x, name: Fuse mapM/map}@@ -436,11 +642,17 @@     - warn: {lhs: flip traverse_, rhs: for_}     - warn: {lhs: flip for_, rhs: traverse_}     - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_}+    - warn: {lhs: foldr (*>) (return ()), rhs: sequence_}     - warn: {lhs: foldr (<|>) empty, rhs: asum}     - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)}+    - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)}+    - warn: {lhs: liftA2 f (return x), rhs: fmap (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}+    - warn: {lhs: Just <$> a <|> return Nothing, rhs: optional a}+    - warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"}+    - warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}+    - warn: {lhs: traverse id, rhs: sequenceA}+    - warn: {lhs: traverse_ id, rhs: sequenceA_}       # LIST COMP@@ -448,6 +660,7 @@     - hint: {lhs: "if b then [x] else []", rhs: "[x | b]", name: Use list comprehension}     - hint: {lhs: "if b then [] else [x]", rhs: "[x | not b]", name: Use list comprehension}     - hint: {lhs: "[x | x <- y]", rhs: "y", side: isVar x, name: Redundant list comprehension}+    - hint: {lhs: "[ f x | x <- [y] ]", rhs: "[f y]", side: isVar x, name: Redundant list comprehension}      # SEQ @@ -463,25 +676,45 @@      - warn: {lhs: fst (unzip x), rhs: map fst x}     - warn: {lhs: snd (unzip x), rhs: map snd x}+    - hint: {lhs: "\\x y -> (x, y)", rhs: "(,)"}+    - hint: {lhs: "\\x y z -> (x, y, z)", rhs: "(,,)"}+    - hint: {lhs: "(,b) a", rhs: "(a,b)", side: isAtom a, name: Evaluate}+    - hint: {lhs: "(a,) b", rhs: "(a,b)", side: isAtom b, name: Evaluate}+    - warn: {lhs: "Data.List.NonEmpty.unzip", rhs: "Data.Functor.unzip", name: "Avoid NonEmpty.unzip", note: "The function is being deprecated"}      # MAYBE      - warn: {lhs: maybe x id, rhs: Data.Maybe.fromMaybe x}+    - 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 ==), name: Redundant maybe}+    - warn: {lhs: maybe True (x /=), rhs: (Just x /=), name: Redundant maybe}+    - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x, name: Redundant maybe}+    - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x, name: Redundant maybe}+    # The following two hints seem to be somewhat unwelcome, e.g.+    # https://github.com/ndmitchell/hlint/issues/1177+    - ignore: {lhs: fromMaybe False x, rhs: Just True == x, name: Redundant fromMaybe} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053+    - ignore: {lhs: fromMaybe True x, rhs: Just False /= x, name: Redundant fromMaybe}     - warn: {lhs: not (isNothing x), rhs: isJust x}     - warn: {lhs: not (isJust x), rhs: isNothing x}     - warn: {lhs: "maybe [] (:[])", rhs: maybeToList}     - warn: {lhs: catMaybes (map f x), rhs: mapMaybe f x}+    - warn: {lhs: catMaybes (f <$> x), rhs: mapMaybe f x}+    - warn: {lhs: catMaybes (x <&> f), rhs: mapMaybe f x}     - warn: {lhs: catMaybes (fmap f x), rhs: mapMaybe f x}-    - hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, name: Replace case with fromMaybe}-    - hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, name: Replace case with fromMaybe}+    - hint: {lhs: case x of Nothing -> y; Just a -> a , rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}+    - hint: {lhs: case x of Just a -> a; Nothing -> y, rhs: Data.Maybe.fromMaybe y x, side: isAtom y, name: Replace case with fromMaybe}+    - hint: {lhs: case x of Nothing -> y; Just a -> f a , rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe}+    - hint: {lhs: case x of Just a -> f a; Nothing -> y, rhs: maybe y f x, side: isAtom y && isAtom f, name: Replace case with maybe}     - warn: {lhs: if isNothing x then y else f (fromJust x), rhs: maybe y f x}     - warn: {lhs: if isJust x then f (fromJust x) else y, rhs: maybe y f x}     - warn: {lhs: maybe Nothing (Just . f), rhs: fmap f}-    - hint: {lhs: map fromJust . filter isJust , rhs:  Data.Maybe.catMaybes}+    - hint: {lhs: map fromJust (filter isJust x), rhs:  Data.Maybe.catMaybes x}+    - hint: {lhs: filter isJust (map f x), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+    - hint: {lhs: filter isJust (f <*> x), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+    - hint: {lhs: filter isJust (x <&> f), rhs: map Just (mapMaybe f x), name: Use mapMaybe}+    - hint: {lhs: filter isJust (fmap f x), rhs: map Just (mapMaybe f x), name: Use mapMaybe}     - warn: {lhs: x == Nothing , rhs:  isNothing x}     - warn: {lhs: Nothing == x , rhs:  isNothing x}     - warn: {lhs: x /= Nothing , rhs:  Data.Maybe.isJust x}@@ -492,31 +725,69 @@     - warn: {lhs: if isNothing x then y else fromJust x, rhs: fromMaybe y x}     - warn: {lhs: if isJust x then fromJust x else y, rhs: fromMaybe y x}     - warn: {lhs: isJust x && (fromJust x == y), rhs: x == Just y}+    - warn: {lhs: isJust y && (x == fromJust y), rhs: Just x == y}     - warn: {lhs: mapMaybe f (map g x), rhs: mapMaybe (f . g) x, name: Fuse mapMaybe/map}     - warn: {lhs: fromMaybe a (fmap f x), rhs: maybe a f x}     - warn: {lhs: fromMaybe a (f <$> x), rhs: maybe a f x}+    - warn: {lhs: fromMaybe a (x <&> f), rhs: maybe a f x}     - warn: {lhs: mapMaybe id, rhs: catMaybes}-    - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}+    - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a, side: isVar x}     - 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}+    - warn: {lhs: maybe x f (g <$> y), rhs: maybe x (f . g) y, name: Redundant <$>}+    - warn: {lhs: maybe x f (y <&> g), rhs: maybe x (f . g) y, name: Redundant <&>}     - warn: {lhs: maybe x f (fmap g y), rhs: maybe x (f . g) y, name: Redundant fmap}+    - warn: {lhs: isJust (f <$> x), rhs: isJust x}+    - warn: {lhs: isJust (x <&> f), rhs: isJust x}     - warn: {lhs: isJust (fmap f x), rhs: isJust x}+    - warn: {lhs: isNothing (f <$> x), rhs: isNothing x}+    - warn: {lhs: isNothing (x <&> f), rhs: isNothing x}     - warn: {lhs: isNothing (fmap f x), rhs: isNothing x}-    - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x)}+    - warn: {lhs: fromJust (f <$> x), rhs: f (fromJust x), note: IncreasesLaziness}+    - warn: {lhs: fromJust (x <&> f), rhs: f (fromJust x), note: IncreasesLaziness}+    - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x), note: IncreasesLaziness}+    - warn: {lhs: mapMaybe f (g <$> x), rhs: mapMaybe (f . g) x, name: Redundant <$>}+    - warn: {lhs: mapMaybe f (x <&> g), rhs: mapMaybe (f . g) x, name: Redundant <&>}     - warn: {lhs: mapMaybe f (fmap g x), rhs: mapMaybe (f . g) x, name: Redundant fmap}+    - warn: {lhs: catMaybes (nub x), rhs: nub (catMaybes x), name: Move nub out}+    - warn: {lhs: lefts (nub x), rhs: nub (lefts x), name: Move nub out}+    - warn: {lhs: rights (nub x), rhs: nub (rights x), name: Move nub out}+    - warn: {lhs: catMaybes (reverse x), rhs: reverse (catMaybes x), name: Move reverse out}+    - warn: {lhs: lefts (reverse x), rhs: reverse (lefts x), name: Move reverse out}+    - warn: {lhs: rights (reverse x), rhs: reverse (rights x), name: Move reverse out}+    - warn: {lhs: catMaybes (sort x), rhs: sort (catMaybes x), name: Move sort out}+    - warn: {lhs: lefts (sort x), rhs: sort (lefts x), name: Move sort out}+    - warn: {lhs: rights (sort x), rhs: sort (rights x), name: Move sort out}+    - warn: {lhs: catMaybes (nubOrd x), rhs: nubOrd (catMaybes x), name: Move nubOrd out}+    - warn: {lhs: lefts (nubOrd x), rhs: nubOrd (lefts x), name: Move nubOrd out}+    - warn: {lhs: rights (nubOrd x), rhs: nubOrd (rights x), name: Move nubOrd out}+    - warn: {lhs: filter f (reverse x), rhs: reverse (filter f x), name: Move reverse out}+    - warn: {lhs: mapMaybe f (reverse x), rhs: reverse (mapMaybe f x), name: Move reverse out}      # EITHER -    - warn: {lhs: "[a | Left a <- a]", rhs: lefts a}-    - warn: {lhs: "[a | Right a <- a]", rhs: rights a}+    - warn: {lhs: "[a | Left a <- b]", rhs: lefts b, side: isVar a}+    - warn: {lhs: "[a | Right a <- b]", rhs: rights b, side: isVar a}     - warn: {lhs: either Left (Right . f), rhs: fmap f}     - warn: {lhs: either f g (fmap h x), rhs: either f (g . h) x, name: Redundant fmap}+    - warn: {lhs: either f g (h <$> x), rhs: either f (g . h) x, name: Redundant <$>}+    - warn: {lhs: either f g (x <&> h), rhs: either f (g . h) x, name: Redundant <&>}     - warn: {lhs: isLeft (fmap f x), rhs: isLeft x}+    - warn: {lhs: isLeft (f <$> x), rhs: isLeft x}+    - warn: {lhs: isLeft (x <&> f), rhs: isLeft x}     - warn: {lhs: isRight (fmap f x), rhs: isRight x}+    - warn: {lhs: isRight (f <$> x), rhs: isRight x}+    - warn: {lhs: isRight (x <&> f), rhs: isRight x}     - warn: {lhs: fromLeft x (fmap f y), rhs: fromLeft x y}+    - warn: {lhs: fromLeft x (f <$> y), rhs: fromLeft x y}+    - warn: {lhs: fromLeft x (y <&> f), rhs: fromLeft x y}     - warn: {lhs: fromRight x (fmap f y), rhs: either (const x) f y}+    - warn: {lhs: fromRight x (f <$> y), rhs: either (const x) f y}+    - warn: {lhs: fromRight x (y <&> f), rhs: either (const x) f y}+    - warn: {lhs: either (const x) id, rhs: fromRight x}+    - warn: {lhs: either id (const x), rhs: fromLeft x}+    - warn: {lhs: either Left f x, rhs: f =<< x}      # INFIX @@ -541,6 +812,10 @@     - hint: {lhs: 0 == rem n 2, rhs: even n}     - hint: {lhs: rem n 2 /= 0, rhs: odd n}     - hint: {lhs: 0 /= rem n 2, rhs: odd n}+    - hint: {lhs: mod n 2 == 0, rhs: even n}+    - hint: {lhs: 0 == mod n 2, rhs: even n}+    - hint: {lhs: mod n 2 /= 0, rhs: odd n}+    - hint: {lhs: 0 /= mod n 2, rhs: odd n}     - hint: {lhs: not (even x), rhs: odd x}     - hint: {lhs: not (odd x), rhs: even x}     - hint: {lhs: x ** 0.5, rhs: sqrt x}@@ -550,7 +825,10 @@     # CONCURRENT      - hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a}-    - error: {lhs: atomically (readTVar x), rhs: readTVarIO x}+    - warn: {lhs: atomically (readTVar x), rhs: readTVarIO x}+    - warn: {lhs: atomically (newTVar x), rhs: newTVarIO x}+    - warn: {lhs: atomically (newTMVar x), rhs: newTMVarIO x}+    - warn: {lhs: atomically newEmptyTMVar, rhs: newEmptyTMVarIO}      # TYPEABLE @@ -591,17 +869,89 @@      # FOLDABLE +    - warn: {lhs: case m of Nothing -> pure (); Just x -> f x, rhs: Data.Foldable.for_ m f}     - warn: {lhs: case m of Nothing -> return (); Just x -> f x, rhs: Data.Foldable.forM_ m f}+    - warn: {lhs: case m of Just x -> f x; Nothing -> pure (), rhs: Data.Foldable.for_ m f}     - warn: {lhs: case m of Just x -> f x; Nothing -> return (), rhs: Data.Foldable.forM_ m f}+    - warn: {lhs: case m of Just x -> f x; _ -> pure (), rhs: Data.Foldable.for_ m f}     - warn: {lhs: case m of Just x -> f x; _ -> return (), rhs: Data.Foldable.forM_ m f}-    - warn: {lhs: when (isJust m) (f (fromJust m)), rhs: Data.Foldable.forM_ m f}+    - warn: {lhs: when (isJust m) (f (fromJust m)), rhs: Data.Foldable.for_ m f}+    - hint: {lhs: concatMap f (fmap g x), rhs: concatMap (f . g) x, name: Fuse concatMap/fmap}+    - hint: {lhs: concatMap f (g <$> x), rhs: concatMap (f . g) x, name: Fuse concatMap/<$>}+    - hint: {lhs: concatMap f (x <&> g), rhs: concatMap (f . g) x, name: Fuse concatMap/<&>}+    - warn: {lhs: null (concatMap f x), rhs: all (null . f) x}+    - warn: {lhs: or (concat x), rhs: any or x}+    - warn: {lhs: or (concatMap f x), rhs: any (or . f) x}+    - warn: {lhs: and (concat x), rhs: all and x}+    - warn: {lhs: and (concatMap f x), rhs: all (and . f) x}+    - warn: {lhs: any f (concat x), rhs: any (any f) x, name: Use any nested}+    - warn: {lhs: any f (concatMap g x), rhs: any (any f . g) x, name: Use any nested}+    - warn: {lhs: all f (concat x), rhs: all (all f) x, name: Use all nested}+    - warn: {lhs: all f (concatMap g x), rhs: all (all f . g) x, name: Use all nested}+    - warn: {lhs: fold (concatMap f x), rhs: foldMap (fold . f) x}+    - warn: {lhs: foldMap f (concatMap g x), rhs: foldMap (foldMap f . g) x, name: Use foldMap nested}+    - warn: {lhs: catMaybes (concatMap f x), rhs: concatMap (catMaybes . f) x, name: Move catMaybes}+    - warn: {lhs: catMaybes (concat x), rhs: concatMap catMaybes x, name: Move catMaybes}+    - hint: {lhs: filter f (concatMap g x), rhs: concatMap (filter f . g) x, name: Move filter}+    - hint: {lhs: filter f (concat x), rhs: concatMap (filter f) x, name: Move filter}+    - warn: {lhs: mapMaybe f (concatMap g x), rhs: concatMap (mapMaybe f . g) x, name: Move mapMaybe}+    - warn: {lhs: mapMaybe f (concat x), rhs: concatMap (mapMaybe f) x, name: Move mapMaybe}+    - warn: {lhs: or (fmap p x), rhs: any p x}+    - warn: {lhs: or (p <$> x), rhs: any p x}+    - warn: {lhs: or (x <&> p), rhs: any p x}+    - warn: {lhs: and (fmap p x), rhs: all p x}+    - warn: {lhs: and (p <$> x), rhs: all p x}+    - warn: {lhs: and (x <&> p), rhs: all p x}+    - warn: {lhs: any f (fmap g x), rhs: any (f . g) x}+    - warn: {lhs: any f (g <$> x), rhs: any (f . g) x}+    - warn: {lhs: any f (x <&> g), rhs: any (f . g) x}+    - warn: {lhs: all f (fmap g x), rhs: all (f . g) x}+    - warn: {lhs: all f (g <$> x), rhs: all (f . g) x}+    - warn: {lhs: all f (x <&> g), rhs: all (f . g) x}+    - hint: {lhs: foldr f z (fmap g x), rhs: foldr (f . g) z x, name: Fuse foldr/fmap}+    - hint: {lhs: foldr f z (g <$> x), rhs: foldr (f . g) z x, name: Fuse foldr/<$>}+    - hint: {lhs: foldr f z (x <&> g), rhs: foldr (f . g) z x, name: Fuse foldr/<&>}+    - warn: {lhs: fold (Data.Foldable.toList x), rhs: fold x}+    - warn: {lhs: foldMap f (Data.Foldable.toList x), rhs: foldMap f x}+    - warn: {lhs: foldMap' f (Data.Foldable.toList x), rhs: foldMap' f x}+    - warn: {lhs: foldr f z (Data.Foldable.toList x), rhs: foldr f z x}+    - warn: {lhs: foldr' f z (Data.Foldable.toList x), rhs: foldr' f z x}+    - warn: {lhs: foldl f z (Data.Foldable.toList x), rhs: foldl f z x}+    - warn: {lhs: foldl' f z (Data.Foldable.toList x), rhs: foldl' f z x}+    - warn: {lhs: foldr1 f (Data.Foldable.toList x), rhs: foldr1 f x}+    - warn: {lhs: foldl1 f (Data.Foldable.toList x), rhs: foldl1 f x}+    - warn: {lhs: null (Data.Foldable.toList x), rhs: null x}+    - warn: {lhs: length (Data.Foldable.toList x), rhs: length x}+    - warn: {lhs: elem y (Data.Foldable.toList x), rhs: elem y x}+    - warn: {lhs: notElem y (Data.Foldable.toList x), rhs: notElem y x}+    - warn: {lhs: maximum (Data.Foldable.toList x), rhs: maximum x}+    - warn: {lhs: minimum (Data.Foldable.toList x), rhs: minimum x}+    - warn: {lhs: maximumBy f (Data.Foldable.toList x), rhs: maximumBy f x}+    - warn: {lhs: minimumBy f (Data.Foldable.toList x), rhs: minimumBy f x}+    - warn: {lhs: sum (Data.Foldable.toList x), rhs: sum x}+    - warn: {lhs: product (Data.Foldable.toList x), rhs: product x}+    - warn: {lhs: and (Data.Foldable.toList x), rhs: and x}+    - warn: {lhs: or (Data.Foldable.toList x), rhs: or x}+    - warn: {lhs: all f (Data.Foldable.toList x), rhs: all f x}+    - warn: {lhs: any f (Data.Foldable.toList x), rhs: any f x}+    - warn: {lhs: find f (Data.Foldable.toList x), rhs: find f x}+    - warn: {lhs: concat (Data.Foldable.toList x), rhs: concat x}+    - warn: {lhs: concatMap f (Data.Foldable.toList x), rhs: concatMap f x}      # STATE MONAD      - warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f}+    - warn: {lhs: Control.Monad.State.get <&> f, 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: Control.Monad.State.gets g <&> f, 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: Control.Monad.Reader.ask <&> f, 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: Control.Monad.Reader.asks g <&> f, 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} @@ -619,9 +969,20 @@     - warn: {lhs: either f g (Right y), rhs: g y, name: Evaluate}     - warn: {lhs: "fst (x,y)", rhs: x, name: Evaluate}     - warn: {lhs: "snd (x,y)", rhs: "y", name: Evaluate}+    - warn: {lhs: fromJust (Just x), rhs: x, name: Evaluate}+    - warn: {lhs: fromLeft y (Left x), rhs: x, name: Evaluate}+    - warn: {lhs: fromLeft y (Right x), rhs: "y", name: Evaluate}+    - warn: {lhs: fromRight y (Right x), rhs: x, name: Evaluate}+    - warn: {lhs: fromRight y (Left x), rhs: "y", name: Evaluate}+    - warn: {lhs: "head [x]", rhs: "x", name: Evaluate}+    - warn: {lhs: "last [x]", rhs: "x", name: Evaluate}+    - warn: {lhs: "tail [x]", rhs: "[]", name: Evaluate}     - warn: {lhs: "init [x]", rhs: "[]", name: Evaluate}+    - warn: {lhs: "null [x]", rhs: "False", name: Evaluate}     - warn: {lhs: "null []", rhs: "True", name: Evaluate}+    - warn: {lhs: "null \"\"", rhs: "True", name: Evaluate}     - warn: {lhs: "length []", rhs: "0", name: Evaluate}+    - warn: {lhs: "length \"\"", rhs: "0", name: Evaluate}     - warn: {lhs: "foldl f z []", rhs: z, name: Evaluate}     - warn: {lhs: "foldr f z []", rhs: z, name: Evaluate}     - warn: {lhs: "foldr1 f [x]", rhs: x, name: Evaluate}@@ -629,19 +990,41 @@     - warn: {lhs: "scanr1 f []", rhs: "[]", name: Evaluate}     - warn: {lhs: "scanr1 f [x]", rhs: "[x]", name: Evaluate}     - warn: {lhs: "take n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+    - warn: {lhs: "take n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate}     - warn: {lhs: "drop n []", rhs: "[]", note: IncreasesLaziness, name: Evaluate}+    - warn: {lhs: "drop n \"\"", rhs: "\"\"", note: IncreasesLaziness, name: Evaluate}     - warn: {lhs: "takeWhile p []", rhs: "[]", name: Evaluate}+    - warn: {lhs: "takeWhile p \"\"", rhs: "\"\"", name: Evaluate}     - warn: {lhs: "dropWhile p []", rhs: "[]", name: Evaluate}+    - warn: {lhs: "dropWhile p \"\"", rhs: "\"\"", name: Evaluate}     - warn: {lhs: "span p []", rhs: "([],[])", name: Evaluate}-    - warn: {lhs: lines "", rhs: "[]", name: Evaluate}+    - warn: {lhs: "span p \"\"", rhs: "(\"\",\"\")", name: Evaluate}+    - warn: {lhs: "lines \"\"", rhs: "[]", name: Evaluate}+    - warn: {lhs: "lines []", rhs: "[]", name: Evaluate}     - warn: {lhs: "unwords []", rhs: "\"\"", name: Evaluate}     - warn: {lhs: x - 0, rhs: x, name: Evaluate}     - warn: {lhs: x * 1, rhs: x, name: Evaluate}     - warn: {lhs: x / 1, rhs: x, name: Evaluate}     - warn: {lhs: "concat [a]", rhs: a, name: Evaluate}     - warn: {lhs: "concat []", rhs: "[]", name: Evaluate}+    - warn: {lhs: "concatMap f [a]", rhs: f a, name: Evaluate}+    - warn: {lhs: "concatMap f []", rhs: "[]", name: Evaluate}     - warn: {lhs: "zip [] []", rhs: "[]", name: Evaluate}     - warn: {lhs: const x y, rhs: x, name: Evaluate}+    - warn: {lhs: any (const False), rhs: const False, note: IncreasesLaziness, name: Evaluate}+    - warn: {lhs: all (const True), rhs: const True, note: IncreasesLaziness, name: Evaluate}+    - warn: {lhs: "[] ++ x", rhs: x, name: Evaluate}+    - warn: {lhs: "\"\" ++ x", rhs: x, name: Evaluate}+    - warn: {lhs: "x ++ []", rhs: x, name: Evaluate}+    - warn: {lhs: "x ++ \"\"", rhs: x, name: Evaluate}+    - warn: {lhs: "all f [a]", rhs: f a, name: Evaluate}+    - warn: {lhs: "all f []", rhs: "True", name: Evaluate}+    - warn: {lhs: "any f [a]", rhs: f a, name: Evaluate}+    - warn: {lhs: "any f []", rhs: "False", name: Evaluate}+    - warn: {lhs: "maximum [a]", rhs: a, name: Evaluate}+    - warn: {lhs: "minimum [a]", rhs: a, name: Evaluate}+    - warn: {lhs: "map f []", rhs: "[]", name: Evaluate}+    - warn: {lhs: "map f [a]", rhs: "[f a]", name: Evaluate}      # FOLDABLE + TUPLES @@ -657,9 +1040,11 @@     - warn: {lhs: "toList      (x,b)", rhs: b, name: Using toList on tuple}     - warn: {lhs: "maximum     (x,b)", rhs: b, name: Using maximum on tuple}     - warn: {lhs: "minimum     (x,b)", rhs: b, name: Using minimum on tuple}+    - warn: {lhs: "notElem e   (x,b)", rhs: e /= b, name: Using notElem on tuple}     - warn: {lhs: "sum         (x,b)", rhs: b, name: Using sum on tuple}     - warn: {lhs: "product     (x,b)", rhs: b, name: Using product on tuple}     - warn: {lhs: "concat      (x,b)", rhs: b, name: Using concat on tuple}+    - warn: {lhs: "concatMap f (x,b)", rhs: f b, name: Using concatMap on tuple}     - warn: {lhs: "and         (x,b)", rhs: b, name: Using and on tuple}     - warn: {lhs: "or          (x,b)", rhs: b, name: Using or on tuple}     - warn: {lhs: "any     f   (x,b)", rhs: f b, name: Using any on tuple}@@ -677,9 +1062,11 @@     - warn: {lhs: "toList      (x,y,b)", rhs: b, name: Using toList on tuple}     - warn: {lhs: "maximum     (x,y,b)", rhs: b, name: Using maximum on tuple}     - warn: {lhs: "minimum     (x,y,b)", rhs: b, name: Using minimum on tuple}+    - warn: {lhs: "notElem e   (x,y,b)", rhs: e /= b, name: Using notElem on tuple}     - warn: {lhs: "sum         (x,y,b)", rhs: b, name: Using sum on tuple}     - warn: {lhs: "product     (x,y,b)", rhs: b, name: Using product on tuple}     - warn: {lhs: "concat      (x,y,b)", rhs: b, name: Using concat on tuple}+    - warn: {lhs: "concatMap f (x,y,b)", rhs: f b, name: Using concatMap on tuple}     - warn: {lhs: "and         (x,y,b)", rhs: b, name: Using and on tuple}     - warn: {lhs: "or          (x,y,b)", rhs: b, name: Using or on tuple}     - warn: {lhs: "any     f   (x,y,b)", rhs: f b, name: Using any on tuple}@@ -688,6 +1075,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@@ -698,9 +1091,9 @@     - warn: {lhs: "(a ^. b) ^. c", rhs: "a ^. (b . c)"}     - warn: {lhs: "fromJust (a ^? b)", rhs: "a ^?! b"}     - warn: {lhs: "a .~ Just b", rhs: "a ?~ b"}-    - warn: {lhs: "a & (mapped %~ b)", rhs: "a <&> b"}-    - warn: {lhs: "a & ((mapped . b) %~ c)", rhs: "a <&> b %~ c"}-    - warn: {lhs: "a & (mapped .~ b)", rhs: "b <$ a"}+    - warn: {lhs: "(mapped %~ b) a", rhs: "a <&> b"}+    - warn: {lhs: "((mapped . b) %~ c) a", rhs: "a <&> b %~ c"}+    - warn: {lhs: "(mapped .~ b) a", rhs: "b <$ a"}     - warn: {lhs: "ask <&> (^. a)", rhs: "view a"}     - warn: {lhs: "view a <&> (^. b)", rhs: "view (a . b)"} @@ -708,9 +1101,9 @@      - warn: {lhs: "Control.Lens.at a . Control.Lens._Just", rhs: "Control.Lens.ix a"}     - error: {lhs: "Control.Lens.has (Control.Lens.at a)", rhs: "True"}-    - error: {lhs: "Control.Lens.has (a . Control.Lens.at b)", rhs: "Control.Lens.has a"}+    - warn: {lhs: "Control.Lens.has (a . Control.Lens.at b)", rhs: "Control.Lens.has a"}     - error: {lhs: "Control.Lens.nullOf (Control.Lens.at a)", rhs: "False"}-    - error: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"}+    - warn: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"}  - group:     name: use-lens@@ -723,6 +1116,14 @@     - warn: {lhs: "either (const Nothing) Just", rhs: preview _Right}  - group:+    name: use-th-quotes+    enabled: false+    imports:+    - package base+    rules:+    - hint: {lhs: "TH.varE 'a", rhs: "[|a|]", name: Use TH quotation brackets}++- group:     name: attoparsec     enabled: true     imports:@@ -733,6 +1134,24 @@     - warn: {lhs: Data.Attoparsec.ByteString.option Nothing (Just <$> p), rhs: optional p}  - group:+    name: quickcheck+    enabled: true+    imports:+    - package base+    - package quickcheck+    rules:+    - warn: {lhs: "Test.QuickCheck.choose (x,x)", rhs: return x}+    - warn: {lhs: "Test.QuickCheck.chooseInt (x,x)", rhs: return x}+    - warn: {lhs: "Test.QuickCheck.chooseInteger (x,x)", rhs: return x}+    - warn: {lhs: "Test.QuickCheck.chooseBoundedIntegral (x,x)", rhs: return x}+    - warn: {lhs: "Test.QuickCheck.chooseEnum (x,x)", rhs: return x}+    - warn: {lhs: Control.Monad.join (Test.QuickCheck.elements l), rhs: Test.QuickCheck.oneof l}+    - warn: {lhs: "Test.QuickCheck.elements [x]", rhs: "return x"}+    - warn: {lhs: "Test.QuickCheck.growingElements [x]", rhs: "return x"}+    - warn: {lhs: "Test.QuickCheck.oneof [x]", rhs: "x", name: Evaluate}+    - warn: {lhs: "Test.QuickCheck.frequency [(a,x)]", rhs: "x", name: Evaluate}++- group:     name: generalise     enabled: false     imports:@@ -741,6 +1160,11 @@     - warn: {lhs: map, rhs: fmap}     - warn: {lhs: a ++ b, rhs: a <> b}     - warn: {lhs: "sequence [a]", rhs: "pure <$> a"}+    - warn: {lhs: "x /= []", rhs: not (null x), name: Use null}+    - warn: {lhs: "x /= \"\"", rhs: not (null x), name: Use null}+    - warn: {lhs: "[] /= x", rhs: not (null x), name: Use null}+    - warn: {lhs: "\"\" /= x", rhs: not (null x), name: Use null}+    - warn: {lhs: "maybe []", rhs: foldMap}  - group:     name: generalise-for-conciseness@@ -749,15 +1173,235 @@     - package base     rules:     - warn: {lhs: maybe mempty, rhs: foldMap}+    - warn: {lhs: maybe False, rhs: any}+    - warn: {lhs: maybe True, rhs: all}     - warn: {lhs: either (const mempty), rhs: foldMap}+    - warn: {lhs: either mempty, rhs: foldMap}+    - 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 0, rhs: sum}+    - warn: {lhs: Data.Maybe.fromMaybe 1, rhs: product}+    - warn: {lhs: Data.Maybe.fromMaybe empty, rhs: Data.Foldable.asum}+    - warn: {lhs: Data.Maybe.fromMaybe mzero, rhs: Data.Foldable.msum}     - warn: {lhs: Data.Either.fromRight mempty, rhs: Data.Foldable.fold}+    - warn: {lhs: Data.Either.fromRight False, rhs: or}+    - warn: {lhs: Data.Either.fromRight True, rhs: and}+    - warn: {lhs: Data.Either.fromRight 0, rhs: sum}+    - warn: {lhs: Data.Either.fromRight 1, rhs: product}+    - warn: {lhs: Data.Either.fromRight empty, rhs: Data.Foldable.asum}+    - warn: {lhs: Data.Either.fromRight mzero, rhs: Data.Foldable.msum}     - warn: {lhs: if f x then Just x else Nothing, rhs: mfilter f (Just x)}     - hint: {lhs: maybe (pure ()), rhs: traverse_, note: IncreasesLaziness}     - hint: {lhs: fromMaybe (pure ()), rhs: sequenceA_, note: IncreasesLaziness}     - hint: {lhs: fromRight (pure ()), rhs: sequenceA_, note: IncreasesLaziness}+    - hint: {lhs: "[fst x, snd x]", rhs: Data.Bifoldable.biList x}+    - hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness}+    - hint: {lhs: const mempty, rhs: mempty}+    - hint: {lhs: \x -> mempty, rhs: mempty, name: Redundant lambda}+    - warn: {lhs: map f x >>= g, rhs: x >>= g . f}+    - warn: {lhs: g =<< map f x, rhs: g . f =<< x}+    - hint: {lhs: join (map f x), rhs: f =<< x}+    - warn: {lhs: map unzip (mapM f x), rhs: Control.Monad.mapAndUnzipM f x} +# Warn on partial functions whose use can be avoided relatively easily.+# These functions are in the base package, excluding IO and GHC modules. - group:+    name: partial+    enabled: false+    imports:+    - package base+    rules:++    # Data.Bifoldable++    - warn: {lhs: bifoldr1, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: bifoldl1, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: bimaximum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: biminimum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: bimaximumBy, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: biminimumBy, rhs: undefined, name: Avoid partial function}++    # Data.Bits++    - warn: {lhs: bitSize x, rhs: "case bitSizeMaybe x of Just n -> n; Nothing -> error _", name: Avoid partial function}+    - warn: {lhs: shiftL x b, rhs: shift x b, name: Avoid partial function}+    - warn: {lhs: shiftR x b, rhs: shift x (-b), name: Avoid partial function}+    - warn: {lhs: unsafeShiftL x b, rhs: shift x b, name: Avoid partial function}+    - warn: {lhs: unsafeShiftR x b, rhs: shift x (-b), name: Avoid partial function}+    - warn: {lhs: rotateL x b, rhs: rotate x b, name: Avoid partial function}+    - warn: {lhs: rotateR x b, rhs: rotate x (-b), name: Avoid partial function}++    # Data.Foldable++    - warn: {lhs: foldr1, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: foldl1, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: maximum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: minimum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: maximumBy, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: minimumBy, rhs: undefined, name: Avoid partial function}++    # Data.List++    - warn: {lhs: head l, rhs: "case l of x:_ -> x; [] -> error _", name: Avoid partial function}+    - warn: {lhs: last l, rhs: "case reverse l of x:_ -> x; [] -> error _", name: Avoid partial function}+    - warn: {lhs: tail l, rhs: "case l of _:xs -> xs; [] -> error _", name: Avoid partial function}+    - warn: {lhs: init l, rhs: "case reverse l of _:xs -> reverse xs; [] -> error _", name: Avoid partial function}+    - warn: {lhs: l !! n, rhs: "case drop n l of x:_ -> x; [] -> error _", name: Avoid partial function}++    # Data.List.NonEmpty++    - warn: {lhs: Data.List.NonEmpty.fromList l, rhs: "case nonEmpty l of Just xs -> xs; Nothing -> error _", name: Avoid partial function}++    # Data.Maybe++    - warn: {lhs: fromJust v, rhs: "case v of Just x -> x; Nothing -> error _", name: Avoid partial function}++# Strictly warn even on partial functions in the base package whose use+# are almost unavoidable for their functionality.+- group:+    name: partial-strict+    enabled: false+    imports:+    - package base+    rules:++    # Data.Char++    - warn: {lhs: digitToInt, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: intToDigit, rhs: undefined, name: Avoid partial function}++    # Data.Fixed++    - warn: {lhs: div', rhs: undefined, name: Avoid partial function}+    - warn: {lhs: mod', rhs: undefined, name: Avoid partial function}+    - warn: {lhs: divMod', rhs: undefined, name: Avoid partial function}++    # Data.List++    - warn: {lhs: cycle, rhs: undefined, name: Avoid partial function}++    # Data.Ratio++    - warn: {lhs: x % y, rhs: undefined, name: Avoid partial function}++    # Prelude++    - warn: {lhs: succ, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: pred, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: toEnum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: fromEnum, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: quot, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: rem, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: div, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: mod, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: quotRem, rhs: undefined, name: Avoid partial function}+    - warn: {lhs: divMod, rhs: undefined, name: Avoid partial function}++# 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: map concat (forM a b), rhs: concatForM a b}+    - warn: {lhs: concat <$> forM a b, rhs: concatForM a b}+    - warn: {lhs: forM a b <&> concat, 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 >> pure ()", rhs: "fold1M_ a b"}+    - warn: {lhs: "fold1M a b >> return ()", 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 (pure ())", rhs: "whenM a b"}+    - warn: {lhs: "ifM a b (return ())", rhs: "whenM a b"}+    - warn: {lhs: "ifM a (pure ()) b", rhs: "unlessM a b"}+    - warn: {lhs: "ifM a (return ()) b", rhs: "unlessM a b"}+    - warn: {lhs: "ifM a (pure True) b", rhs: "(||^) a b"}+    - warn: {lhs: "ifM a (return True) b", rhs: "(||^) a b"}+    - warn: {lhs: "ifM a b (pure False)", 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: "allM f [a]", rhs: f a, name: Evaluate}+    - warn: {lhs: "allM f []", rhs: pure True, name: Evaluate}+    - warn: {lhs: "anyM f [a]", rhs: f a, name: Evaluate}+    - warn: {lhs: "anyM f []", rhs: pure False, name: Evaluate}+    - 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: "breakEnd notNull", rhs: "spanEnd null", name: Use spanEnd}+    - warn: {lhs: "breakEnd (notElem x)", rhs: "spanEnd (elem x)", name: Use spanEnd}+    - warn: {lhs: "spanEnd (not . a)", rhs: "breakEnd a"}+    - warn: {lhs: "spanEnd notNull", rhs: "breakEnd null", name: Use breakEnd}+    - warn: {lhs: "spanEnd (notElem x)", rhs: "breakEnd (elem x)", name: Use breakEnd}+    - 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: "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"}+    - warn: {lhs: span notNull, rhs: break null, name: Use break}+    - warn: {lhs: break notNull, rhs: span null, name: Use span}+    - warn: {lhs: when (notNull x), rhs: unless (null x), name: Use unless}+    - warn: {lhs: unless (notNull x), rhs: when (null x), name: Use when}+    - warn: {lhs: not (notNull x), rhs: null x}+    - warn: {lhs: notNull (concat x), rhs: any notNull x}+    - warn: {lhs: notNull (concatMap f x), rhs: any (notNull . f) x}+    - warn: {lhs: notNull (filter f x), rhs: any f x}+    - warn: {lhs: "notNull [x]", rhs: "True", name: Evaluate}+    - warn: {lhs: "notNull []", rhs: "False", name: Evaluate}+    - warn: {lhs: "notNull \"\"", rhs: "False", name: Evaluate}+    - hint: {lhs: "\\(x,y) -> (f x, f y)", rhs: both f}+    - warn: {lhs: fromLeft' (Left x), rhs: x, name: Evaluate}+    - warn: {lhs: fromRight' (Right x), rhs: x, name: Evaluate}+    - warn: {lhs: fromEither (Left x), rhs: x, name: Evaluate}+    - warn: {lhs: fromEither (Right x), rhs: x, name: Evaluate}+    - hint: {lhs: nub (sort x), rhs: nubSort x}+    - warn: {lhs: sort (nub x), rhs: nubSort x}+    - warn: {lhs: notNull x, rhs: "True", side: isTuple x, name: Using notNull on tuple}++# hints that will be enabled in future+- group:+    name: future+    enabled: false+    rules:+    - warn: {lhs: return, rhs: pure}++- group:     name: dollar     enabled: false     imports:@@ -766,6 +1410,42 @@     - 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: codeworld+    enabled: false+    imports:+    - package base+    - package codeworld-api+    rules:+    - warn: {lhs: "pictures []", rhs: blank, name: Evaluate}+    - warn: {lhs: "pictures [ p ]", rhs: p, name: Evaluate}+    - warn: {lhs: "pictures [ p, q ]", rhs: p & q, name: Evaluate}+    - hint: {lhs: foldl1 (&), rhs: pictures}+    - hint: {lhs: foldl (&) blank, rhs: pictures}+    - hint: {lhs: foldl' (&) blank, rhs: pictures}+    - hint: {lhs: foldr' (&) blank, rhs: pictures}+    - hint: {lhs: foldr (&) blank, rhs: pictures}+    - hint: {lhs: foldr1 (&), rhs: pictures}+    - hint: {lhs: scaled x x, rhs: dilated x}+    - hint: {lhs: scaledPoint x x, rhs: dilatedPoint x}+    - warn: {lhs: "brighter (- a)", rhs: "duller a"}+    - warn: {lhs: "lighter (- a)", rhs: "darker a"}+    - warn: {lhs: "duller (- a)", rhs: "brighter a"}+    - warn: {lhs: "darker (- a)", rhs: "lighter a"}+    - warn: {lhs: translated x y (translated u v p), rhs: translated (x + u) (y + v) p, name: Use translated once}+    - warn: {lhs: translated 0 0 p, rhs: p}++- group:     name: teaching     enabled: false     imports:@@ -775,7 +1455,21 @@     - hint: {lhs: "[] /= x", rhs: not (null x), name: Use null}     - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law}     - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law}+    - hint: {lhs: "[ f x | x <- l ]", rhs: map f l, side: isVar x}+    - hint: {lhs: "[ x | x <- l, p x ]", rhs: filter p l, side: isVar x}+    - warn: {lhs: foldr f c (reverse x), rhs: foldl (flip f) c x, name: Use left fold instead of right fold}+    - warn: {lhs: foldr1 f (reverse x), rhs: foldl1 (flip f) x, name: Use left fold instead of right fold}+    - warn: {lhs: foldl f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold}+    - warn: {lhs: foldl1 f (reverse x), rhs: foldr1 (flip f) x, note: IncreasesLaziness, name: Use right fold instead of left fold}+    - warn: {lhs: foldr' f c (reverse x), rhs: foldl' (flip f) c x, name: Use left fold instead of right fold}+    - warn: {lhs: foldl' f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold} +- group:+    # used for tests, enabled when testing this file+    name: testing+    enabled: false+    rules:+    - warn: {lhs: "[issue766| |]", rhs: "mempty", name: "Use mempty"}  # <TEST> # yes = concat . map f -- concatMap f@@ -785,6 +1479,7 @@ # yes = f x where f x = concat . map head -- concatMap head # yes = concat . map f . g -- concatMap f . g # yes = concat $ map f x -- concatMap f x+# yes = map f x & concat -- concatMap f x # yes = "test" ++ concatMap (' ':) ["of","this"] -- unwords ("test":["of","this"]) # yes = if f a then True else b -- f a || b # yes = not (a == b) -- a /= b@@ -795,9 +1490,9 @@ # yes = not . (/= a) -- (== a) # yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 # no  = if a then 1 else if b then 3 else 2-# yes = a >>= return . bob -- bob <$> a+# yes = a >>= return . bob -- a Data.Functor.<&> bob # yes = return . bob =<< a -- bob <$> a-# yes = m alice >>= pure . b -- b <$> m alice+# yes = m alice >>= pure . b -- m alice Data.Functor.<&> b # yes = pure .b =<< m alice -- b <$> m alice # yes = asciiCI "hi" *> pure Hi -- asciiCI "hi" Data.Functor.$> Hi # yes = asciiCI "bye" *> return Bye -- asciiCI "bye" Data.Functor.$> Bye@@ -815,7 +1510,7 @@ # yes = head (reverse xs) -- last xs # yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys # no = putStrLn $ show (length xs) ++ "Test"-# yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper Control.Arrow.*** urlEncode+# yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- Data.Bifunctor.bimap toUpper urlEncode # yes = map (\(a,b) -> a) xs -- fst # yes = map (\(a,_) -> a) xs -- fst # yes = readFile $ args !! 0 -- head args@@ -825,9 +1520,12 @@ # yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \ #     -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff # yes = if foo then stuff else return () -- Control.Monad.when foo stuff-# yes = foo $ \(a, b) -> (a, y + b) -- Control.Arrow.second ((+) y)+# yes = foo $ \(a, b) -> (a, y + b) -- Data.Bifunctor.second ((+) y) # no  = foo $ \(a, b) -> (a, a + b)-# yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10]+# yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (curry (uncurry (+))) [1 .. 5] [6 .. 10]+# yes = curry (uncurry (+)) -- (+)+# yes = fst foo .= snd foo -- uncurry (.=) foo+# yes = fst foo `_ba__'r''` snd foo -- uncurry _ba__'r'' foo # no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter # no = flip f x $ \y -> y*y+y # no = \x -> f x (g x)@@ -841,18 +1539,22 @@ # yes = foo (elem x y) -- x `elem` y # no  = x `elem` y # no  = elem 1 [] : []+# yes = a & (mapped . b) %~ c -- a <&> b %~ c # test a = foo (\x -> True) -- const True # test a = foo (\_ -> True) -- const True+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_ctor x = f (\foo-> Foo{foo})+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_update x = f (\foo -> x{foo}) # test a = foo (\x -> x) -- id # h a = flip f x (y z) -- f (y z) x # h a = flip f x $ y z # yes x = case x of {True -> a ; False -> b} -- if x then a else b # yes x = case x of {False -> a ; _ -> b} -- if x then b else a # no = const . ok . toResponse $ "saved"-# yes = case x z of Nothing -> y z; Just pat -> pat -- Data.Maybe.fromMaybe (y z) (x z)+# yes = case x z of Nothing -> y; Just pat -> pat -- Data.Maybe.fromMaybe y (x z) # yes = if p then s else return () -- Control.Monad.when p s # warn = a $$$$ b $$$$ c ==> a . b $$$$$ c # yes = when (not . null $ asdf) -- unless (null asdf)+# 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@@ -861,6 +1563,8 @@ # no = x ^^ 18.5 # instance Arrow (->) where first f = f *** id # yes = fromInteger 12 -- 12+# yes = if x * y > u * v then x * y else u * v -- max (x * y) (u * v)+# yes = scanl (\x _ -> x + 1) 7 (replicate 8 3) -- take 8 (iterate (\x -> x + 1) 7) # import Prelude hiding (catch); no = catch # import Control.Exception as E; no = E.catch # main = do f; putStrLn $ show x -- print x@@ -872,21 +1576,27 @@ # 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 -- [] # main = take (-y) x # main = take 4 x # main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l+# 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 |]) # 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 ???-# yes = fmap lines $ abc 123 -- lines Control.Applicative.<$> abc 123+# yes = fmap lines $ abc 123 -- lines <$> abc 123 # no = fmap lines $ abc $ def 123 # test = foo . not . not -- id # test = map (not . not) xs -- id@@ -907,6 +1617,8 @@ # foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs # g = \ f -> parseFile f >>= (\ cu -> return (f, cu)) # foo = bar $ \(x,y) -> x x y+# f = const [] . (>>= const Nothing) . const Nothing -- (const Nothing Control.Monad.<=< const Nothing)+# f = g . either Left h x -- (h =<< x) # foo = (\x -> f x >>= g) -- f Control.Monad.>=> g # foo = (\f -> h f >>= g) -- h Control.Monad.>=> g # foo = (\f -> h f >>= f)@@ -915,19 +1627,34 @@ # f condition tChar tBool = if condition then _monoField tChar else _monoField tBool # foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..} # foo = (\a -> Foo {..}) 1-# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (\ x -> SymInfo x ty) [0 ..]+# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (`SymInfo` ty) [0 ..]+# foo = zipWith (SymInfo q) [0 ..] (repeat ty) -- map (( \ x_ -> SymInfo q x_ ty)) [0 .. ] @NoRefactor # f rec = rec # mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x # {-# LANGUAGE TypeApplications #-} \ # foo = id @Int+# {-# LANGUAGE TypeApplications #-} \+# foo = const @_ @SomeException # foo = id 12 -- 12 # yes = foldr (\ curr acc -> (+ 1) curr : acc) [] -- map (\ curr -> (+ 1) curr) # yes = foldr (\ curr acc -> curr + curr : acc) [] -- map (\ curr -> curr + curr) # no = foo $ (,) x $ do {this is a test; and another test} # no = sequence (return x) # no = sequenceA (pure a)+# yes = zipWith func xs ys & sequenceA -- Control.Monad.zipWithM func xs ys # {-# 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+# issue1055 = map f ((sort . map g) xs)+# issue1049 = True `elem` xs -- or xs+# issue1049 = elem True -- or+# issue1062 = bar (\(f, x) -> baz () () . f $ x) -- uncurry ((.) (baz () ()))+# issue1058 n = [] ++ issue1058 (n+1) -- issue1058 (n+1)+# issue1183 = (a >= 'a') && a <= 'z' -- isAsciiLower a+# issue1183 = (a >= 'a') && (a <= 'z') -- isAsciiLower a+# issue1218 = uncurry (zipWith g) $ (a, b) -- zipWith g a b  # import Prelude \ # yes = flip mapM -- Control.Monad.forM@@ -956,12 +1683,43 @@ # import Prelude((==)) \ # import qualified Prelude as P \ # main = P.length xs == 0 -- P.null xs+# import Prelude () \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Foo \+# main = length xs == 0 -- null xs+# import Prelude () \+# import Data.Text (length) \+# main = length xs == 0+# import Prelude () \+# import qualified Data.Text (length) \+# main = length xs == 0 -- null xs # main = hello .~ Just 12 -- hello ?~ 12 # foo = liftIO $ window `on` deleteEvent $ do a; b # no = sort <$> f input `shouldBe` sort <$> x-# sortBy (comparing snd) -- sortOn snd+# no = sortBy (comparing Down)+# yes = sortBy (flip (comparing f)) -- sortBy (comparing (Data.Ord.Down . f))+# yes = reverse (sort x) -- sortBy (comparing Data.Ord.Down) x # myJoin = on $ child ^. ChildParentId ==. parent ^. ParentId # 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}+# f = map (flip (,) "a") "123" -- (,"a")+# test1196 = map (flip (,) (+ 1)) "123" -- (,(+ 1))+# f = map ((,) "a") "123" -- ("a",)+# test1196 = map ((,) (+ 1)) "123" -- ((+ 1),)+# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here+# infixl 4 <*! \+# test993 = f =<< g <$> x <*! y+# {-# LANGUAGE QuasiQuotes #-} \+# test = [issue766| |] -- mempty+# {-# LANGUAGE QuasiQuotes #-} \+# test = [issue766| x |] # </TEST>
+ data/import_style.yaml view
@@ -0,0 +1,8 @@+- modules:+  - {name: HypotheticalModule1, as: HM1, asRequired: true}+  - {name: HypotheticalModule2, importStyle: explicitOrQualified}+  - {name: HypotheticalModule3, importStyle: qualified}+  - {name: 'HypotheticalModule3.*', importStyle: unqualified}+  - {name: 'HypotheticalModule3.OtherSubModule', importStyle: unrestricted, qualifiedStyle: post}+  - {name: HypotheticalModule4, importStyle: qualified, as: HM4, asRequired: true}+  - {name: HypotheticalModule5, importStyle: qualified, qualifiedStyle: post}
+ data/test-restrict.yaml view
@@ -0,0 +1,19 @@+- modules:+  - {name: Restricted.Module, within: []}+  - {name: Restricted.Module.Message, within: [], message: "Custom message"}+  - {name: Restricted.Module.BadIdents, badidents: ['bad']}+  - {name: Restricted.Module.OnlyIdents, only: ['good']}++- functions:+  - {name: restricted, within: []}+  - {name: restrictedMessage, within: [], message: "Custom message"}++- extensions:+  - {name: DeriveFunctor, within: []}+  - {name: DeriveTraversable, within: [], message: "Custom message"}+++# Test https://github.com/ndmitchell/hlint/issues/766+- warn:+    lhs: "[hamlet| |]"+    rhs: "mempty"
+ data/wildcards.yaml view
@@ -0,0 +1,31 @@+- modules:+  - { name: A, as: A }+  - { name: '*B', as: B }+  - { name: '**.C', as: C }+  - { name: '**.*D', as: D }+  - { name: E, within: E }+  - { name: F, within: '*F' }+  - { name: G, within: '**.G' }+  - { name: H, within: '**.*H' }+  - { name: '**.*U', within: '**.*U' }+- ignore:+    name: Use const+    within:+    - I+    - '*J'+    - '**.K'+    - '**.*L'+- extensions:+  - name: CPP+    within:+    - M+    - '*N'+    - '**.O'+    - '**.*P'+- functions:+  - name: read+    within:+    - Q+    - '*R'+    - '**.S'+    - '**.*T'
hlint.cabal view
@@ -1,13 +1,13 @@-cabal-version:      >= 1.18+cabal-version:      1.18 build-type:         Simple name:               hlint-version:            2.1.26+version:            3.10 license:            BSD3 license-file:       LICENSE category:           Development author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2006-2019+copyright:          Neil Mitchell 2006-2025 synopsis:           Source code suggestions description:     HLint gives suggestions on how to improve your source code.@@ -24,10 +24,19 @@     hlint.ghci     HLint_QuickCheck.hs     HLint_TypeCheck.hs+extra-source-files:+    .hlint.yaml+    data/*.hs+    data/*.yaml+    tests/*.test+    -- These are needed because of haskell/cabal#7862+    data/default.yaml+    data/hlint.yaml+    data/report_template.html extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.6.5, GHC==8.4.4+tested-with:        GHC==9.12, GHC==9.10, GHC==9.8  source-repository head     type:     git@@ -43,40 +52,68 @@     manual: True     description: Use GPL libraries, specifically hscolour +flag ghc-lib+  default: True+  manual: True+  description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported++flag hsyaml+  default: False+  manual: True+  description: Use HsYAML instead of yaml+ library     default-language:   Haskell2010     build-depends:         base == 4.*, process, filepath, directory, containers,         unordered-containers, vector, text, bytestring,         transformers,+        file-embed,+        utf8-string,         data-default >= 0.3,         cpphs >= 1.20.1,-        cmdargs >= 0.10,-        yaml >= 0.5.0,-        haskell-src-exts >= 1.21 && < 1.22,-        haskell-src-exts-util >= 0.2.5,+        cmdargs >= 0.10.22,         uniplate >= 1.5,-        ansi-terminal >= 0.6.2,-        extra >= 1.6.6,+        ansi-terminal >= 0.8.1,+        extra >= 1.7.3,         refact >= 0.3,-        aeson >= 1.1.2.0,-        ghc-lib-parser == 8.8.0.20190424+        aeson >= 1.3,+        deriving-aeson >= 0.2,+        filepattern >= 0.1.1 +    if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0)+      build-depends:+        ghc == 9.12.*,+        ghc-boot-th,+        ghc-boot+    else+      build-depends:+          ghc-lib-parser == 9.12.*+    build-depends:+        ghc-lib-parser-ex >= 9.12.0.0 && < 9.13.0+     if flag(gpl)         build-depends: hscolour >= 1.21     else         cpp-options: -DGPL_SCARES_ME +    if flag(hsyaml)+        build-depends:+          HsYAML >= 0.2,+          HsYAML-aeson >= 0.2+        cpp-options: -DHS_YAML+    else+        build-depends: yaml >= 0.5.0+     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@@ -86,25 +123,35 @@         Refact         Timing         CC+        EmbedData+        SARIF+        Summary         Config.Compute         Config.Haskell         Config.Read         Config.Type         Config.Yaml++        GHC.All         GHC.Util-        HSE.All-        HSE.Match-        HSE.Reduce-        HSE.Scope-        HSE.Type-        HSE.Unify-        HSE.Util+        GHC.Util.ApiAnnotation+        GHC.Util.View+        GHC.Util.Brackets+        GHC.Util.DynFlags+        GHC.Util.FreeVars+        GHC.Util.HsDecl+        GHC.Util.HsExpr+        GHC.Util.SrcLoc+        GHC.Util.Scope+        GHC.Util.Unify+         Hint.All         Hint.Bracket         Hint.Comment         Hint.Duplicate         Hint.Export         Hint.Extensions+        Hint.Fixities         Hint.Import         Hint.Lambda         Hint.List@@ -112,6 +159,7 @@         Hint.Match         Hint.Monad         Hint.Naming+        Hint.Negation         Hint.NewType         Hint.Pattern         Hint.Pragma@@ -119,13 +167,12 @@         Hint.Smell         Hint.Type         Hint.Unsafe-        Hint.Util+        Hint.NumLiteral         Test.All         Test.Annotations         Test.InputOutput-        Test.Proof-        Test.Translate         Test.Util+    ghc-options: -Wunused-binds -Wunused-imports -Worphans -Wprepositive-qualified-module   executable hlint@@ -133,6 +180,8 @@     build-depends:      base, hlint     main-is:            src/Main.hs -    ghc-options:        -rtsopts+    -- See https://github.com/ndmitchell/hlint/pull/1169 for benchmarks+    -- that indicate -A32 is a good idea+    ghc-options:        -rtsopts -with-rtsopts=-A32m     if flag(threaded)         ghc-options:    -threaded
src/Apply.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE ImportQualifiedPost #-}  module Apply(applyHints, applyHintFile, applyHintFiles) where  import Control.Applicative import Data.Monoid-import HSE.All+import GHC.All import Hint.All+import GHC.Util+import Data.Generics.Uniplate.DataOnly import Idea import Data.Tuple.Extra import Data.Either@@ -13,24 +16,29 @@ import Data.Ord import Config.Type import Config.Haskell-import qualified Data.HashSet as Set+import GHC.Types.SrcLoc+import GHC.Hs hiding (comments)+import Language.Haskell.GhclibParserEx.GHC.Hs+import Data.HashSet qualified as Set import Prelude+import Util+import Timing   -- | Apply hints to a single file, you may have the contents of the file. 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]+        Right m -> timed "Execute hints" file (forceList $ executeHints s [m])   -- | Apply hints to multiple files, allowing cross-file hints to fire. 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 ++ timed "Execute hints" "all modules" (forceList $ executeHints s ms)   -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.@@ -40,52 +48,65 @@ --   When given multiple modules at once this function attempts to find hints between modules, --   which is slower and often pointless (by default HLint passes modules singularly, using --   @--cross@ to pass all modules together).-applyHints {- PUBLIC -} :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea]+applyHints {- PUBLIC -} :: [Classify] -> Hint -> [ModuleEx] -> [Idea] applyHints cs = applyHintsReal $ map SettingClassify cs -applyHintsReal :: [Setting] -> Hint -> [(Module_, [Comment])] -> [Idea]+applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] applyHintsReal settings hints_ ms = concat $     [ map (classify classifiers . removeRequiresExtensionNotes m) $         order [] (hintModule hints settings nm m) `merge`-        concat [order [fromNamed d] $ decHints d | d <- moduleDecls m] `merge`-        concat [order [] $ hintComment hints settings c | c <- cs]-    | (nm,(m,cs)) <- mns-    , let classifiers = cls ++ mapMaybe readPragma (universeBi m) ++ concatMap readComment cs+        concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ unLoc $ ghcModule m]+    | (nm,m) <- mns+    , 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-    , let order n = map (\i -> i{ideaModule= f $ moduleName m : ideaModule i, ideaDecl= f $ n ++ ideaDecl i}) . sortOn ideaSpan-    , let merge = mergeBy (comparing ideaSpan)] ++-    [map (classify cls) (hintModules hints settings $ map (second fst) mns)]+    , let order n = map (\i -> i{ideaModule = f $ modName (ghcModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn (SrcSpanD . ideaSpan)+    , let merge = mergeBy (comparing (SrcSpanD . ideaSpan))] +++    [map (classify cls) (hintModules hints settings mns)]     where         f = nubOrd . filter (/= "")         cls = [x | SettingClassify x <- settings]-        mns = map (scopeCreate . fst &&& id) ms+        mns = map (\x -> (scopeCreate (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 $ languagePragmas $ pragmas (comments (hsmodAnn (hsmodExt . unLoc . ghcModule $ m)))         keep (RequiresExtension x) = not $ x `Set.member` exts         keep _ = True  -- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules.-executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea]+executeHints :: [Setting] -> [ModuleEx] -> [Idea] executeHints s = applyHintsReal s (allHints s)   -- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor.-parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea (Module_, [Comment]))+parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea ModuleEx) parseModuleApply flags s file src = do     res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src     case res of-        Right (ModuleEx (m, c) _)  -> return $ Right (m,c)-        Left (ParseError sl msg ctxt) ->-            return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []+      Right r -> pure $ Right r+      Left (ParseError sl msg ctxt) ->+            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 (+            case stripInfix "parse error " x of+              Nothing -> x+              Just (prefix, _) ->+                dropPrefix (prefix ++ "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@@ -95,10 +116,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 == "" || any (wildcardMatch x) y+        x  ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y)
src/CC.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- |@@ -12,15 +13,16 @@  import Data.Aeson (ToJSON(..), (.=), encode, object) import Data.Char (toUpper)-import Data.Monoid ((<>)) 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 Data.Text qualified as T+import Data.ByteString.Lazy.Char8 qualified as C8  import Idea (Idea(..), Severity(..)) +import GHC.Types.SrcLoc qualified as GHC+import GHC.Util qualified as GHC+ data Issue = Issue     { issueType :: Text     , issueCheckName :: Text@@ -120,11 +122,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
src/CmdLine.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}+{-# LANGUAGE ImportQualifiedPost, CPP #-}+{-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-}+{-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-}  module CmdLine(     Cmd(..), getCmd,@@ -8,31 +9,39 @@     ) where  import Control.Monad.Extra-import qualified Data.ByteString as BS+import Control.Exception.Extra+import Data.ByteString qualified as BS import Data.Char-import Data.List+import Data.List.NonEmpty qualified as NE+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.All(CppFlags(..))+import GHC.LanguageExtensions.Type+import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx+import GHC.Driver.Session hiding (verbosity)+ import Language.Preprocessor.Cpphs import System.Console.ANSI(hSupportsANSI) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) import System.Console.CmdArgs.Implicit import System.Directory.Extra-import System.Environment.Extra+import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Error-import System.Info.Extra import System.Process+import System.FilePattern +import EmbedData import Util+import Timing+import Extension import Paths_hlint import Data.Version import Prelude+import Config.Type (Severity (Warning))   getCmd :: [String] -> IO Cmd@@ -41,33 +50,30 @@   automatic :: Cmd -> IO Cmd-automatic cmd = case cmd of-    CmdMain{} -> dataDir =<< path =<< git =<< extension cmd-    CmdGrep{} -> path =<< extension cmd-    CmdTest{} -> dataDir cmd-    _ -> return cmd+automatic cmd = dataDir =<< path =<< git =<< extension 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+                        files <- timedIO "Execute" (unwords $ git:args) $+                            readProcess git args ""+                        pure cmd{cmdFiles = cmdFiles cmd ++ lines files}+            | otherwise = pure cmd   exitWithHelp :: IO a@@ -80,26 +86,26 @@ data ColorMode     = Never  -- ^ Terminal output will never be coloured.     | Always -- ^ Terminal output will always be coloured.-    | Auto   -- ^ Terminal output will be coloured if $TERM and stdout appear to support it.+    | Auto   -- ^ Terminal output will be coloured if $TERM and stdout appear to support it, and NO_COLOR is not set.       deriving (Show, Typeable, Data)   instance Default ColorMode where-  def = if isWindows then Never else Auto+  def = Auto   data Cmd     = CmdMain         {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+        ,cmdGivenHints :: [FilePath]     -- ^ which settings files were explicitly given         ,cmdWithGroups :: [String]       -- ^ groups that are given on the command line         ,cmdGit :: Bool                  -- ^ use git ls-files to find files         ,cmdColor :: ColorMode           -- ^ color the result-        ,cmdThreads :: Int              -- ^ Numbmer of threads to use, 0 = whatever GHC has+        ,cmdThreads :: Int              -- ^ Number of threads to use, 0 = whatever GHC has         ,cmdIgnore :: [String]           -- ^ the hints to ignore         ,cmdShowAll :: Bool              -- ^ display all skipped items+        ,cmdIgnoreSuggestions :: Bool    -- ^ ignore suggestions         ,cmdExtension :: [String]        -- ^ extensions         ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")         ,cmdCross :: Bool                -- ^ work between source files, applies to hints such as duplicate code between modules@@ -114,6 +120,7 @@         ,cmdCppAnsi :: Bool         ,cmdJson :: Bool                -- ^ display hint data as JSON         ,cmdCC :: Bool                  -- ^ display hint data as Code Climate Issues+        ,cmdSARIF :: Bool               -- ^ display hint data as SARIF         ,cmdNoSummary :: Bool           -- ^ do not show the summary info         ,cmdOnly :: [String]            -- ^ specify which hints explicitly         ,cmdNoExitCode :: Bool@@ -122,32 +129,11 @@         ,cmdRefactor :: Bool            -- ^ Run the `refactor` executable to automatically perform hints         ,cmdRefactorOptions :: String   -- ^ Options to pass to the `refactor` executable.         ,cmdWithRefactor :: FilePath    -- ^ Path to refactor tool-        }-    | CmdGrep-        {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given-        ,cmdPattern :: String-        ,cmdExtension :: [String]        -- ^ extensions-        ,cmdLanguage :: [String]      -- ^ the extensions (may be prefixed by "No")-        ,cmdPath :: [String]-        ,cmdCppDefine :: [String]-        ,cmdCppInclude :: [FilePath]-        ,cmdCppFile :: [FilePath]-        ,cmdCppSimple :: Bool-        ,cmdCppAnsi :: Bool-        }-    | CmdTest-        {cmdProof :: [FilePath]          -- ^ a proof script to check against-        ,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")+        ,cmdIgnoreGlob :: [FilePattern]+        ,cmdGenerateMdSummary :: [FilePath]  -- ^ Generate a summary of available hints, in Markdown format+        ,cmdGenerateJsonSummary :: [FilePath]  -- ^ Generate a summary of built-in hints, in JSON format+        ,cmdGenerateExhaustiveConf :: [Severity]  -- ^ Generate a hlint config file with all built-in hints set to the specified level+        ,cmdTest :: Bool         }     deriving (Data,Typeable,Show) @@ -156,13 +142,13 @@         {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)"+        ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires an ANSI terminal; 'auto' means on if the standard output channel can support ANSI; by itself, selects 'always')"         ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)"         ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"         ,cmdShowAll = nam "show" &= help "Show all ignored ideas"+        ,cmdIgnoreSuggestions = nam_ "ignore-suggestions" &= help "Ignore suggestions, only show warnings and errors"         ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"         ,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)"         ,cmdCross = nam_ "cross" &= help "Work between modules"@@ -177,6 +163,7 @@         ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"         ,cmdJson = nam_ "json" &= help "Display hint data as JSON"         ,cmdCC = nam_ "cc" &= help "Display hint data as Code Climate Issues"+        ,cmdSARIF = nam_ "sarif" &= help "Display hint data as SARIF"         ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information"         ,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly"         ,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"@@ -185,76 +172,75 @@         ,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints"         ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"         ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"+        ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern (e.g. foo/bar/*.hs)"+        ,cmdGenerateMdSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of available hints, in Markdown format"+        ,cmdGenerateJsonSummary = nam_ "generate-summary-json" &= opt "hints.json" &= help "Generate a summary of available hints, in JSON format"+        ,cmdGenerateExhaustiveConf = nam_ "generate-config" &= opt Warning &= typ "LEVEL" &= help "Generate a .hlint.yaml config file with all hints set to the specified severity level (default level: warn, alternatives: ignore, suggest, error)"+        ,cmdTest = nam_ "test" &= help "Run the test suite"         } &= auto &= explicit &= name "lint"-    ,CmdGrep-        {cmdFiles = def &= args &= typ "FILE/DIR"-        ,cmdPattern = def &= argPos 0 &= typ "PATTERN"-        } &= explicit &= name "grep"-    ,CmdTest-        {cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"-        ,cmdTypeCheck = nam_ "typecheck" &= help "Use GHC to type check the hints"-        ,cmdQuickCheck = nam_ "quickcheck" &= help "Use QuickCheck to check the hints"-        ,cmdTempDir = nam_ "tempdir" &= help "Where to put temporary files (not cleaned up)"-        } &= explicit &= name "test"         &= details ["HLint gives hints on how to improve Haskell code."                    ,""                    ,"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-2019")+    &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2025")     where-        nam xs = nam_ xs &= name [head xs]+        nam xs = nam_ xs &= name [NE.head $ NE.fromList xs]         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]+cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)] cmdHintFiles cmd = do-    let explicit1 = [cmdDataDir cmd </> "hlint.yaml" | null $ cmdWithHints cmd]-    let explicit2 = cmdGivenHints cmd-    bad <- filterM (notM . doesFileExist) $ explicit1 ++ 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 /= []+                  || cmdGenerateMdSummary cmd /= []+                  || cmdGenerateJsonSummary cmd /= []+                  || cmdGenerateExhaustiveConf cmd /= [] 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 ++ 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], [Extension])) cmdExtensions = getExtensions . cmdLanguage   cmdCpp :: Cmd -> CppFlags cmdCpp cmd     | cmdCppSimple cmd = CppSimple-    | EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions+    | otherwise = 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] ++ [("__GLASGOW_HASKELL__", show (__GLASGOW_HASKELL__ :: Int))]         }-    | otherwise = NoCpp   -- | Determines whether to use colour or not. cmdUseColour :: Cmd -> IO Bool-cmdUseColour cmd = case cmdColor cmd of-  Always -> return True-  Never  -> return False-  Auto   -> hSupportsANSI stdout-+cmdUseColour cmd = do+  -- https://no-color.org+  -- if NO_COLOR is set, regardless of value, we do not colour output.+  noColor <- lookupEnv "NO_COLOR"+  case cmdColor cmd of+    Always -> pure True+    Never  -> pure False+    Auto   -> do+      supportsANSI <- hSupportsANSI stdout+      pure $ supportsANSI && isNothing noColor  "." <\> x = x x <\> y = x </> y@@ -265,30 +251,41 @@     -> Maybe FilePath -- ^ Temporary file     -> FilePath       -- ^ File to resolve, may be "-" for stdin     -> IO [FilePath]-resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd)+resolveFile cmd = getFile (toPredicate $ cmdIgnoreGlob cmd) (cmdPath cmd) (cmdExtension cmd)+    where+        toPredicate :: [FilePattern] -> FilePath -> Bool+        toPredicate [] = const False+        toPredicate globs = \x -> not $ null $ m [((), cleanup x)]+            where m = matchMany (map ((),) globs) +        cleanup :: FilePath -> FilePath+        cleanup ('.':x:xs) | isPathSeparator x, not $ null xs = xs+        cleanup x = x -getFile :: [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]-getFile path _ (Just tmpfile) "-" =++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 ["-"]-getFile [] exts _ file = exitMessage $ "Couldn't find file: " ++ file-getFile (p:ath) exts t file = do+    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-        xs <- listFilesInside (return . not . avoidDir) $ p <\> file-        return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x]+        let ignoredDirectories = ["dist", "dist-newstyle"]+            avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories || ignore x+            avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore 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 | not $ ignore $ p <\> file]          else do             res <- getModule p exts file             case res of-                Just x -> return [x]-                Nothing -> getFile ath exts t file+                Just x -> pure [x]+                Nothing -> getFile ignore ath exts t file   getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath)@@ -299,28 +296,52 @@         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 defaultExtensions else []) exts)-    where-        lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls+getExtensions :: [String] -> (Maybe Language, ([Extension], [Extension]))+getExtensions args = (lang, foldl f (startExts, []) exts)+  where+        -- If a language specifier is provided e.g. Haskell98 or+        -- Haskell2010 or GHC2021, then it represents a specific set+        -- of extensions which we default enable.++        -- If no language specifier is provided we construct our own+        -- set of extensions to default enable. The set that we+        -- construct default enables more extensions than GHC would+        -- default enable were it to be invoked without an explicit+        -- language specifier given.+        startExts :: [Extension]+        startExts = case lang of+          Nothing -> defaultExtensions+          Just _ -> GHC.Driver.Session.languageExtensions lang++        -- If multiple languages are given, the last language "wins".+        lang :: Maybe Language+        lang = fromJust . flip lookup ls . snd <$> unsnoc langs++        langs, exts :: [String]         (langs, exts) = partition (isJust . flip lookup ls) args-        ls = [(show x, x) | x <- knownLanguages] -        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+        ls :: [(String, Language)]+        ls = [(show x, x) | x <- enumerate] +        f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension])+        f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e)+        f (a, e) x | Just x <- GhclibParserEx.readExtension x = (x : delete x a, delete x e)+        f (a, e) x = error $ "Unknown extension: '" ++ x ++ "'" -readExtension :: String -> Maybe Extension-readExtension x = case classifyExtension x of-    UnknownExtension _ -> Nothing-    x -> Just x+        deletes :: [Extension] -> [Extension] -> [Extension]+        deletes [] ys = ys+        deletes (x : xs) ys = deletes xs $ delete x ys++        -- if you disable a feature that implies another feature, sometimes we should disable both+        -- e.g. no one knows what TemplateHaskellQuotes is https://github.com/ndmitchell/hlint/issues/1038+        expandDisable :: Extension -> [Extension]+        expandDisable TemplateHaskell = [TemplateHaskell, TemplateHaskellQuotes]+        expandDisable x = [x]
src/Config/Compute.hs view
@@ -1,12 +1,22 @@+{-# 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.All+import GHC.Util import Config.Type-import Config.Haskell-import Data.Monoid+import Fixity+import Data.Generics.Uniplate.DataOnly+import GHC.Hs hiding (Warning)+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Prelude  @@ -17,46 +27,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 :: LocatedA (HsDecl GhcPs) -> [Setting]+findSetting (L _ (ValD _ x)) = findBind x+findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =+    concatMap (findBind . unLoc) 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 noAnn LamSingle 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 _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})+    = if length pats == length ps then findExp name (vs++ps) $ unLoc x else []+    where ps = [rdrNameStr x | L _ (VarPat _ x) <- 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 $ nlHsPar $ noLocA $ HsApp noExtField y $ noLocA $ 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 $ noLocA $ transform f bod+        rhs = apps $ map noLocA $ HsVar noExtField (noLocA 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 (rdrNameStr x) rep = y+        f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar 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 . noLocA . Unqual . mkVarOcc
src/Config/Haskell.hs view
@@ -1,99 +1,71 @@-{-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-}-+{-# LANGUAGE ImportQualifiedPost #-}+{-# 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)+import Text.Read import Data.Tuple.Extra import Data.Maybe import Config.Type import Util import Prelude --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 (ModuleEx (m, cs) _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment cs)----- | 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-        [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b]-    | 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+import GHC.Util -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 GHC.Types.SrcLoc+import GHC.Hs.Extension+import GHC.Hs.Decls hiding (SpliceDecl)+import GHC.Hs.Expr hiding (Match)+import GHC.Hs.Lit+import GHC.Data.FastString+import GHC.Parser.Annotation+import GHC.Utils.Outputable+import GHC.Data.Strict qualified +import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader  -- | 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) -> occNameStr x+            TypeAnnProvenance (L _ x) -> occNameStr x+            ModuleAnnProvenance -> ""++        f :: LocatedA (HsExpr GhcPs) -> Maybe Classify+        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 -readComment :: Comment -> [Classify]-readComment o@(Comment True _ x)+readComment :: LEpaComment -> [Classify]+readComment c@(L pos (EpaComment EpaBlockComment{} _))     | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x     , x <- trim x     , (hlint, x) <- word1 x     , lower hlint == "hlint"     = f hash x     where+        x = commentText c         f hash x             | Just x <- if hash then stripSuffix "#" x else Just x             , (sev, x) <- word1 x             , Just sev <- getSeverity sev             , (things, x) <- g x-            , Just (hint :: String) <- if x == "" then Just "" else readMaybe x+            , Just hint <- if x == "" then Just "" else readMaybe x             = map (Classify sev hint "") $ ["" | null things] ++ things-        f hash _ = errorOnComment o $ "bad HLINT pragma, expected:\n    {-" ++ h ++ " HLINT <severity> <identifier> \"Hint name\" " ++ h ++ "-}"+        f hash _ = errorOnComment c $ "bad HLINT pragma, expected:\n    {-" ++ h ++ " HLINT <severity> <identifier> \"Hint name\" " ++ h ++ "-}"             where h = ['#' | hash]          g x | (s, x) <- word1 x@@ -104,59 +76,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 => LocatedA a -> String -> b+errorOn (L pos val) msg = exitMessageImpure $+    showSrcSpan (locA pos) ++     ": Error while reading hint file, " ++ msg ++ "\n" ++-    prettyPrint val+    unsafePrettyPrint val -errorOnComment :: Comment -> String -> b-errorOnComment (Comment b ann x) msg = exitMessageImpure $-    showSrcLoc (getPointLoc ann) +++errorOnComment :: LEpaComment -> String -> b+errorOnComment c@(L s _) msg = exitMessageImpure $+    let isMultiline = isCommentMultiline c in+    showSrcSpan (RealSrcSpan (epaLocationRealSrcSpan s) GHC.Data.Strict.Nothing) ++     ": Error while reading hint file, " ++ msg ++ "\n" ++-    (if b then "{-" else "--") ++ x ++ (if b then "-}" else "")+    (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
src/Config/Read.hs view
@@ -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
src/Config/Type.hs view
@@ -1,16 +1,32 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}  module Config.Type(     Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),-    Restrict(..), RestrictType(..), SmellType(..),+    Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..),+    RestrictImportStyle(..), QualifiedStyle(..),     defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType     ) where -import HSE.All import Data.Char import Data.List.Extra+import Data.Monoid import Prelude  +import GHC.Hs qualified+import Fixity+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Deriving.Aeson+import System.Console.CmdArgs.Implicit+import Data.Aeson hiding (Error)+ getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore getSeverity "warn" = Just Warning@@ -37,8 +53,9 @@     = 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.-      deriving (Eq,Ord,Show,Read,Bounded,Enum)+    | Error -- ^ Available as a setting for the user. Only parse errors have this setting by default.+      deriving (Eq,Ord,Show,Read,Bounded,Enum,Generic,Data)+      deriving (ToJSON) via CustomJSON '[FieldLabelModifier CamelToSnake] Severity   -- Any 1-letter variable names are assumed to be unification variables@@ -85,26 +102,68 @@     }     deriving Show ++ -- | A @LHS ==> RHS@ style hint rule.-data HintRule {- PUBLIC -} = HintRule+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'.+    ,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 +instance ToJSON HintRule where+    toJSON HintRule{..} = object+        [ "name" .= hintRuleName+        , "lhs" .= show hintRuleLHS+        , "rhs" .= show hintRuleRHS+        ]+ data RestrictType = RestrictModule | RestrictExtension | RestrictFlag | RestrictFunction deriving (Show,Eq,Ord) +data RestrictIdents+    = NoRestrictIdents -- No restrictions on module imports+    | ForbidIdents [String] -- Forbid importing the given identifiers from this module+    | OnlyIdents [String] -- Forbid importing all identifiers from this module, except the given identifiers+    deriving Show++instance Semigroup RestrictIdents where+    NoRestrictIdents <> ri = ri+    ri <> NoRestrictIdents = ri+    ForbidIdents x1 <> ForbidIdents y1 = ForbidIdents $ x1 <> y1+    OnlyIdents x1 <> OnlyIdents x2 = OnlyIdents $ x1 <> x2+    ri1 <> ri2 = error $ "Incompatible restrictions: " ++ show (ri1, ri2)++data RestrictImportStyle+  = ImportStyleQualified+  | ImportStyleUnqualified+  | ImportStyleExplicit+  | ImportStyleExplicitOrQualified+  | ImportStyleUnrestricted+  deriving Show++data QualifiedStyle+  = QualifiedStylePre+  | QualifiedStylePost+  | QualifiedStyleUnrestricted+  deriving Show+ data Restrict = Restrict     {restrictType :: RestrictType     ,restrictDefault :: Bool     ,restrictName :: [String]     ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as+    ,restrictAsRequired :: Alt Maybe Bool -- for RestrictModule only+    ,restrictImportStyle :: Alt Maybe RestrictImportStyle -- for RestrictModule only+    ,restrictQualifiedStyle :: Alt Maybe QualifiedStyle -- for RestrictModule only     ,restrictWithin :: [(String, String)]+    ,restrictIdents :: RestrictIdents -- for RestrictModule only, what identifiers can be imported from it+    ,restrictMessage :: Maybe String     } deriving Show  data SmellType = SmellLongFunctions | SmellLongTypeLists | SmellManyArgFunctions | SmellManyImports@@ -124,5 +183,5 @@     | SettingArgument String -- ^ Extra command-line argument     | SettingSmell SmellType Int     | Builtin String -- use a builtin hint set-    | Infix Fixity+    | Infix FixityInfo       deriving Show
src/Config/Yaml.hs view
@@ -1,42 +1,119 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}  module Config.Yaml(     ConfigYaml,+    ConfigYamlBuiltin (..),+    ConfigYamlUser (..),     readFileConfigYaml,-    settingsFromConfigYaml+    settingsFromConfigYaml,+    isBuiltinYaml,     ) where +#if defined(MIN_VERSION_aeson)+#if MIN_VERSION_aeson(2,0,0)+#define AESON 2+#else+#define AESON 1+#endif+#else+#define AESON 2+#endif++import GHC.Driver.Ppr+import GHC.Driver.Errors.Types+import GHC.Types.Error hiding (Severity)+ import Config.Type-import Data.Yaml-import Data.Either+import Data.Either.Extra import Data.Maybe+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Data.Tuple.Extra import Control.Monad.Extra-import Control.Exception.Extra-import qualified Data.Text as T-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.Text qualified as T+import Data.Vector qualified as V+import Data.ByteString.Char8 qualified as BS+import Data.HashMap.Strict qualified as Map+import Data.Generics.Uniplate.DataOnly+import GHC.All+import Fixity+import Extension+import GHC.Unit.Module import Data.Functor+import Data.Monoid import Data.Semigroup import Timing-import Util import Prelude +import GHC.Data.Bag+import GHC.Parser.Lexer+import GHC.Utils.Error hiding (Severity)+import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import GHC.Util (baseDynFlags, Scope, scopeCreate)+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import Data.Char+#if AESON == 2+import Data.Aeson.KeyMap (toHashMapText)+#endif +#ifdef HS_YAML++import Data.YAML (Pos)+import Data.YAML.Aeson (encode1Strict, decode1Strict)+import Data.Aeson hiding (encode)+import Data.Aeson.Types (Parser)+import Data.ByteString qualified as BSS++decodeFileEither :: FilePath -> IO (Either (Pos, String) ConfigYaml)+decodeFileEither path = decode1Strict <$> BSS.readFile path++decodeEither' :: BSS.ByteString -> Either (Pos, String) ConfigYaml+decodeEither' = decode1Strict++displayException :: (Pos, String) -> String+displayException = show++encode :: Value -> BSS.ByteString+encode = encode1Strict++#else++import Data.Yaml+import Control.Exception.Extra++#endif++#if AESON == 1+toHashMapText :: a -> a+toHashMapText = id+#endif+ -- | 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+        Nothing ->+            if isBuiltinYaml file+                then mapRight getConfigYamlBuiltin <$> decodeFileEither file+                else mapRight getConfigYamlUser <$> decodeFileEither file+        Just src -> pure $+            if isBuiltinYaml file+                then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack src+                else mapRight getConfigYamlUser $ 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 +isBuiltinYaml :: FilePath -> Bool+isBuiltinYaml = (== "data/hlint.yaml")  --------------------------------------------------------------------- -- YAML DATA TYPE@@ -51,13 +128,13 @@  data Package = Package     {packageName :: String-    ,packageModules :: [ImportDecl S]+    ,packageModules :: [HsExtendInstances (LImportDecl GhcPs)]     } deriving Show  data Group = Group     {groupName :: String     ,groupEnabled :: Bool-    ,groupImports :: [Either String (ImportDecl S)] -- Left for package imports+    ,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))]     ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty     } deriving Show @@ -87,15 +164,15 @@     -- aim to show a smallish but relevant context     dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)     where-        (steps, contexts) = unzip $ reverse path+        (steps, contexts) = Prelude.unzip $ reverse path         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 (toHashMapText x) parseObject v = parseFail v "Expected an Object"  parseObject1 :: Val -> Parser (String, Val)@@ -106,7 +183,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@@ -116,8 +193,18 @@ parseArrayString :: Val -> Parser [String] parseArrayString = parseArray >=> mapM parseString +maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a)+maybeParse parseValue Nothing = pure Nothing+maybeParse parseValue (Just value) = Just <$> parseValue value++maybeParseEnum :: [(T.Text, a)] -> Maybe Val -> Parser (Maybe a)+maybeParseEnum _ Nothing = pure Nothing+maybeParseEnum dict (Just val) = case getVal val of+  String str | Just x <- lookup str dict -> pure $ Just x+  _ -> parseFail val . T.unpack $ "expected '" <> T.intercalate "', '" (fst <$> dict) <> "'"+ 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@@ -125,49 +212,63 @@     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     mp <- parseObject v     let bad = map T.unpack (Map.keys mp) \\ allow     when (bad /= []) $-        parseFail v $ "Not allowed keys: " ++ unwords bad+        parseFail v+          $ "Not allowed keys: " ++ unwords bad+          ++ ", Allowed keys: " ++ unwords allow -parseHSE :: (ParseMode -> String -> ParseResult v) -> Val -> Parser v-parseHSE parser v = do+parseGHC :: (ParseFlags -> String -> ParseResult v) -> Val -> Parser v+parseGHC parser v = do     x <- parseString v-    case parser defaultParseMode{extensions=defaultExtensions} x of-        ParseOk x -> return x-        ParseFailed loc s -> parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n  " ++ x-+    case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of+        POk _ x -> pure x+        PFailed ps ->+          let errMsg = NE.head . NE.fromList . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)+              msg = showSDoc baseDynFlags $ pprLocMsgEnvelopeDefault 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 x = parseConfigYaml $ newVal x+newtype ConfigYamlBuiltin = ConfigYamlBuiltin { getConfigYamlBuiltin :: ConfigYaml }+  deriving (Semigroup, Monoid) -parseConfigYaml :: Val -> Parser ConfigYaml-parseConfigYaml v = do+newtype ConfigYamlUser = ConfigYamlUser { getConfigYamlUser :: ConfigYaml }+  deriving (Semigroup, Monoid)++instance FromJSON ConfigYamlBuiltin where+    parseJSON Null = pure mempty+    parseJSON x = ConfigYamlBuiltin <$> parseConfigYaml True (newVal x)++instance FromJSON ConfigYamlUser where+  parseJSON Null = pure mempty+  parseJSON x = ConfigYamlUser <$> parseConfigYaml False (newVal x)++parseConfigYaml :: Bool -> Val -> Parser ConfigYaml+parseConfigYaml isBuiltin v = do     vs <- parseArray v-    fmap ConfigYaml $ forM vs $ \o@v -> do-        (s, v) <- parseObject1 v+    fmap ConfigYaml $ forM vs $ \o -> do+        (s, v) <- parseObject1 o         case s of             "package" -> ConfigPackage <$> parsePackage v-            "group" -> ConfigGroup <$> parseGroup v+            "group" -> ConfigGroup <$> parseGroup isBuiltin v             "arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v             "fixity" -> ConfigSetting <$> parseFixity v             "smell" -> ConfigSetting <$> parseSmell v-            _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o+            _ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule isBuiltin o             _ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r))             _ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction" @@ -175,14 +276,14 @@ parsePackage :: Val -> Parser Package parsePackage v = do     packageName <- parseField "name" v >>= parseString-    packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)+    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]@@ -190,47 +291,50 @@   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+parseGroup :: Bool -> Val -> Parser Group+parseGroup isBuiltin v = do     groupName <- parseField "name" v >>= parseString-    groupEnabled <- parseFieldOpt "enabled" v >>= maybe (return True) parseBool-    groupImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImport)-    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 isBuiltin)     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+                 ("package", x) -> pure $ Left x+                 _ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v  ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] -parseRule :: Val -> Parser [Either HintRule Classify]-parseRule v = do+parseRule :: Bool -> Val -> Parser [Either HintRule Classify]+parseRule isBuiltin 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)+        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-        return [Left HintRule{hintRuleSeverity=severity, ..}]+        pure $+          Left HintRule {hintRuleSeverity = severity, hintRuleLHS = extendInstances lhs, hintRuleRHS = extendInstances rhs, ..}+            : [Right $ Classify severity hintRuleName "" "" | not isBuiltin]      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@@ -239,40 +343,75 @@         Just def -> do             b <- parseBool def             allowFields v ["default"]-            return $ Restrict restrictType b [] [] []+            pure $ Restrict restrictType b [] mempty mempty mempty mempty [] NoRestrictIdents Nothing         Nothing -> do-            restrictName <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString-            restrictWithin <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin)-            restrictAs <- parseFieldOpt "as" v >>= maybe (return []) parseArrayString-            allowFields v $ ["as" | restrictType == RestrictModule] ++ ["name","within"]-            return Restrict{restrictDefault=True,..}+            restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString+            restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)+            restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString+            restrictAsRequired <- parseFieldOpt "asRequired" v >>= fmap Alt . maybeParse parseBool+            restrictImportStyle <- parseFieldOpt "importStyle" v >>= fmap Alt . maybeParseEnum+              [ ("qualified"          , ImportStyleQualified)+              , ("unqualified"        , ImportStyleUnqualified)+              , ("explicit"           , ImportStyleExplicit)+              , ("explicitOrQualified", ImportStyleExplicitOrQualified)+              , ("unrestricted"       , ImportStyleUnrestricted)+              ]+            restrictQualifiedStyle <- parseFieldOpt "qualifiedStyle" v >>= fmap Alt . maybeParseEnum+              [ ("pre"         , QualifiedStylePre)+              , ("post"        , QualifiedStylePost)+              , ("unrestricted", QualifiedStyleUnrestricted)+              ] ++            restrictBadIdents <- parseFieldOpt "badidents" v+            restrictOnlyAllowedIdents <- parseFieldOpt "only" v+            restrictIdents <-+                case (restrictBadIdents, restrictOnlyAllowedIdents) of+                    (Just badIdents, Nothing) -> ForbidIdents <$> parseArrayString badIdents+                    (Nothing, Just onlyIdents) -> OnlyIdents <$> parseArrayString onlyIdents+                    (Nothing, Nothing) -> pure NoRestrictIdents+                    _ -> parseFail v "The following options are mutually exclusive: badidents, only"++            restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString+            allowFields v $+                ["name", "within", "message"] +++                if restrictType == RestrictModule+                    then ["as", "asRequired", "importStyle", "qualifiedStyle", "badidents", "only"]+                    else []+            pure Restrict{restrictDefault=True,..}+ parseWithin :: Val -> Parser [(String, String)] -- (module, decl) parseWithin v = do-    x <- parseHSE parseExpWithMode 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)]-        _ -> parseFail v "Bad classification rule"+    s <- parseString v+    if '*' `elem` s+        then pure [(s, "")]+        else do+            x <- parseGHC parseExpGhcWithMode v+            case x of+                L _ (HsVar _ (L _ (Unqual x))) -> pure $ f "" (occNameString x)+                L _ (HsVar _ (L _ (Qual mod x))) -> pure $ f (moduleNameString mod) (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 = occNameStr x, not $ isUnifyVar y, y /= "."]   asNote :: String -> Note@@ -293,17 +432,18 @@         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 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}) SettingClassify) groupRules-            where scope = asScope packageMap groupImports+            | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope'}) SettingClassify) groupRules+            where+              scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) -asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope-asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []+asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope+asScope' packages xs = scopeCreate (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing 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+                   | otherwise = error $ "asScope' failed to do lookup, " ++ x
+ src/EmbedData.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++module EmbedData+  ( hlintYaml,+    defaultYaml,+    reportTemplate,+  )+where++import Data.ByteString.UTF8+import Data.FileEmbed++-- Use NOINLINE below to avoid dirtying too much when these files change++{-# NOINLINE hlintYaml #-}+hlintYaml :: (FilePath, Maybe String)+hlintYaml = ("data/hlint.yaml", Just $ toString $(embedFile "data/hlint.yaml"))++{-# NOINLINE defaultYaml #-}+defaultYaml :: String+defaultYaml = toString $(embedFile "data/default.yaml")++{-# NOINLINE reportTemplate #-}+reportTemplate :: String+reportTemplate = toString $(embedFile "data/report_template.html")
+ src/Extension.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ImportQualifiedPost #-}+module Extension(+  defaultExtensions,+  configExtensions,+  extensionImpliedEnabledBy,+  extensionImplies+  ) where++import Data.List.Extra+import Data.Map qualified as Map+import GHC.LanguageExtensions.Type+import Language.Haskell.GhclibParserEx.GHC.Driver.Session qualified 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+  , LexicalNegation -- changes '-', see https://github.com/ndmitchell/hlint/issues/1230+  -- These next two change syntax significantly and must be opt-in.+  , OverloadedRecordDot+  , OverloadedRecordUpdate+  ]++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.+  , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default,+               -- so adding it here has no effect, but it may not be the case in future GHC releases.+  , MonadComprehensions -- Discussed in https://github.com/ndmitchell/hlint/issues/1261+  ]++-- | 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
+ src/Fixity.hs view
@@ -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 GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.Fixity+import GHC.Parser.Annotation+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+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)) =+    [(rdrNameStr name, f dir, i) | name <- names]+    where+        f InfixL = LeftAssociative+        f InfixR = RightAssociative+        f InfixN = NotAssociative++toFixity :: FixityInfo -> (String, Fixity)+toFixity (name, dir, i) = (name, Fixity 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 NoNamespaceSpecifier [noLocA $ 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.
+ src/GHC/All.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.All(+    CppFlags(..), ParseFlags(..), defaultParseFlags,+    parseFlagsAddFixities, parseFlagsSetLanguage,+    ParseError(..), ModuleEx(..),+    parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, firstDeclComments,+    parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,+    ) where++import GHC.Driver.Ppr+import Control.Monad.Trans.Except+import Control.Monad.IO.Class+import Util+import Data.Char+import Data.List+import Data.List.NonEmpty qualified as NE+import Data.List.Extra+import Timing+import Language.Preprocessor.Cpphs+import System.IO.Extra+import Fixity+import Extension+import GHC.Data.FastString++import GHC.Hs hiding (comments)+import GHC.Types.SrcLoc+import GHC.Types.Fixity+import GHC.Types.Error+import GHC.Driver.Errors.Types++import GHC.Utils.Error+import GHC.Parser.Lexer hiding (context)+import GHC.LanguageExtensions.Type+import GHC.Driver.Session hiding (extensions)+import GHC.Data.Bag+import Data.Generics.Uniplate.DataOnly++import Language.Haskell.GhclibParserEx.GHC.Parser+import Language.Haskell.GhclibParserEx.Fixity+import Language.Haskell.GhclibParserEx.GHC.Driver.Session++import GHC.Util++-- | What C pre processor should be used.+data CppFlags+    = CppSimple -- ^ Lines prefixed with @#@ are stripped.+    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.++-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.+data ParseFlags = ParseFlags+    {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').+    ,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.+    ,enabledExtensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.+    ,disabledExtensions :: [Extension] -- ^ List of extensions disabled for parsing, usually empty.+    ,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.+    }++-- | Default value for 'ParseFlags'.+defaultParseFlags :: ParseFlags+defaultParseFlags = ParseFlags CppSimple Nothing defaultExtensions [] defaultFixities++-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.+parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags+parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x}++parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags+parseFlagsSetLanguage (l, (es, ds)) x = x{baseLanguage = l, enabledExtensions = es, disabledExtensions = ds}+++runCpp :: CppFlags -> FilePath -> String -> IO String+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+        dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b+        dropLine x = x++---------------------------------------------------------------------+-- PARSING++-- | A parse error.+data ParseError = ParseError+    { parseErrorLocation :: 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.+newtype ModuleEx = ModuleEx {+    ghcModule :: Located (HsModule GhcPs)+}++-- | Extract a complete list of all the comments in a module.+ghcComments :: ModuleEx -> [LEpaComment]+ghcComments = universeBi . ghcModule++-- | Extract just the list of a modules' leading comments (pragmas).+modComments :: ModuleEx -> EpAnnComments+modComments = comments . hsmodAnn . hsmodExt . unLoc . ghcModule++-- | Extract comments associated with the first declaration of a module.+firstDeclComments :: ModuleEx -> EpAnnComments+firstDeclComments m =+  case hsmodDecls . unLoc . ghcModule $ m of+        [] -> EpaCommentsBalanced [] []+        L ann _ : _ -> comments ann++-- | The error handler invoked when GHC parsing has failed.+ghcFailOpParseModuleEx :: String+                       -> FilePath+                       -> String+                       -> (SrcSpan, SDoc)+                       -> IO (Either ParseError ModuleEx)+ghcFailOpParseModuleEx ppstr file str (loc, err) = do+   let pe = case loc of+            RealSrcSpan r _ -> context (srcSpanStartLine r) ppstr+            _ -> ""+       msg = GHC.Driver.Ppr.showSDoc baseDynFlags err+   pure $ Left $ ParseError loc msg pe++-- GHC extensions to enable/disable given HSE parse flags.+ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])+ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)++-- GHC fixities given HSE parse flags.+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Types.Fixity.Fixity)]+ghcFixitiesFromParseFlags = map toFixity . fixities++-- These next two functions get called from 'Config/Yaml.hs' for user+-- defined hint rules.++parseModeToFlags :: ParseFlags -> DynFlags+parseModeToFlags parseMode =+  flip lang_set (baseLanguage parseMode) $ foldl xopt_unset (foldl' xopt_set baseDynFlags enable) disable+  where+    (enable, disable) = ghcExtensionsFromParseFlags parseMode++parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)+parseExpGhcWithMode parseMode s =+  let fixities = ghcFixitiesFromParseFlags parseMode+  in case parseExpression s $ parseModeToFlags parseMode of+    POk pst a -> POk pst $ applyFixities fixities a+    f@PFailed{} -> f++parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)+parseImportDeclGhcWithMode parseMode s =+  parseImport s $ parseModeToFlags parseMode++parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)+parseDeclGhcWithMode parseMode s =+  let fixities = ghcFixitiesFromParseFlags parseMode+  in case parseDeclaration s $ parseModeToFlags parseMode of+    POk pst a -> POk pst $ applyFixities fixities a+    f@PFailed{} -> f++-- | Create a 'ModuleEx' from a GHC module. It is assumed the incoming+-- parsed module has not been adjusted to account for operator+-- fixities (it uses the HLint default fixities).+createModuleEx :: Located (HsModule GhcPs) -> ModuleEx+createModuleEx = createModuleExWithFixities (map toFixity defaultFixities)++createModuleExWithFixities :: [(String, Fixity)] -> Located (HsModule GhcPs) -> ModuleEx+createModuleExWithFixities fixities ast =+  ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast)++impliedEnables :: Extension -> [Extension]+impliedEnables ext = case Data.List.lookup ext extensionImplications of+  Just exts -> ext : fst exts+  Nothing -> [ext]++impliedDisables :: Extension -> [Extension]+impliedDisables ext = case Data.List.lookup ext extensionImplications  of+  Just exts -> ext : snd exts+  Nothing -> []++-- | 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.+--+-- Note that certain programs, e.g. @main = do@ successfully parse+-- with GHC, but then fail with an error in the renamer. These+-- programs will return a successful parse.+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)+parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do+  str <- case str of+    Just x -> pure x+    Nothing | file == "-" -> liftIO getContentsUTF8+            | otherwise -> liftIO $ readFileUTF8' file+  str <- pure $ dropPrefix "\65279" str -- Remove the BOM if it exists, see #130.+  let (enable, disable) = ghcExtensionsFromParseFlags flags+  -- Enable/disable extensions and the extensions they imply.+      impliedEnabled = concatMap impliedEnables enable+      impliedDisabled = concatMap impliedDisables disable+      enableDisableExts = (impliedEnabled, impliedDisabled)+  -- Read pragmas for the first time.+  dynFlags <- withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)+  dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags+  -- Avoid running cpp unless CPP is enabled, see #1075.+  str <- if not (xopt Cpp dynFlags) then pure str else liftIO $ runCpp (cppFlags flags) file str+  -- If we preprocessed the file, re-read the pragmas.+  dynFlags <- if not (xopt Cpp dynFlags) then pure dynFlags+              else withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)+  dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags+  -- Done with pragmas. Proceed to parsing.+  case fileToModule file str dynFlags of+    POk s a -> do+      let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s)+      if not $ null errs then+        ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList errs+      else do+        let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags+        pure $ ModuleEx (applyFixities fixes a)+    PFailed s ->+      ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)+  where+    -- If parsing pragmas fails, synthesize a parse error from the+    -- error message.+    parsePragmasErr src msg =+      let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)+      in ParseError (mkSrcSpan loc loc) msg src++    parseFailureErr dynFlags ppstr file str errs =+      let errMsg = NE.head errs+          loc = errMsgSpan errMsg+          doc = pprLocMsgEnvelopeDefault errMsg+      in ghcFailOpParseModuleEx ppstr file str (loc, doc)++-- | 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 = drop (3 - lineNo) ["  ","  ","> ","  ","  "]
src/GHC/Util.hs view
@@ -1,216 +1,113 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  module GHC.Util (-    baseDynFlags+    module GHC.Util.View+  , module GHC.Util.FreeVars+  , module GHC.Util.ApiAnnotation+  , module GHC.Util.HsDecl+  , module GHC.Util.HsExpr+  , module GHC.Util.SrcLoc+  , module GHC.Util.DynFlags+  , module GHC.Util.Scope+  , module GHC.Util.Unify   , parsePragmasIntoDynFlags-  , parseFileGhcLib-  , ParseResult (..)-  , pprErrMsgBagWithLoc-  , getMessages-  , SDoc-  , Located-  , readExtension-  -- Temporary : Export these so GHC doesn't consider them unused and-  -- tell weeder to ignore them.-  , isAtom, addParen, paren, isApp, isOpApp, isAnyApp, isDot, isSection, isDotApp+  , fileToModule+  , pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn+  , pattern SrcLoc, srcFilename, srcLine, srcColumn+  , showSrcSpan,   ) where -import "ghc-lib-parser" HsSyn-import "ghc-lib-parser" BasicTypes-import "ghc-lib-parser" RdrName-import "ghc-lib-parser" DynFlags-import "ghc-lib-parser" Platform-import "ghc-lib-parser" Fingerprint-import "ghc-lib-parser" Config-import "ghc-lib-parser" Lexer-import "ghc-lib-parser" Parser-import "ghc-lib-parser" SrcLoc-import "ghc-lib-parser" FastString-import "ghc-lib-parser" StringBuffer-import "ghc-lib-parser" ErrUtils-import "ghc-lib-parser" Outputable-import "ghc-lib-parser" GHC.LanguageExtensions.Type-import "ghc-lib-parser" Panic-import "ghc-lib-parser" HscTypes-import "ghc-lib-parser" HeaderInfo--import Data.List-import System.FilePath-import Language.Preprocessor.Unlit-import qualified Data.Map.Strict as Map--fakeSettings :: Settings-fakeSettings = Settings-  { sTargetPlatform=platform-  , sPlatformConstants=platformConstants-  , sProjectVersion=cProjectVersion-  , sProgramName="ghc"-  , sOpt_P_fingerprint=fingerprint0-  }-  where-    platform =-      Platform{platformWordSize=8-              , platformOS=OSUnknown-              , platformUnregisterised=True}-    platformConstants =-      PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}--fakeLlvmConfig :: (LlvmTargets, LlvmPasses)-fakeLlvmConfig = ([], [])--badExtensions :: [Extension]-badExtensions =-  [-    AlternativeLayoutRule-  , AlternativeLayoutRuleTransitional-  , Arrows-  , TransformListComp-  , UnboxedTuples-  , UnboxedSums-  , QuasiQuotes-  , RecursiveDo- ]--enabledExtensions :: [Extension]-enabledExtensions = filter (`notElem` badExtensions) enumerateExtensions--baseDynFlags :: DynFlags-baseDynFlags = foldl' xopt_set-             (defaultDynFlags fakeSettings fakeLlvmConfig) enabledExtensions---- | Adjust the input 'DynFlags' to take into account language--- extensions to explicitly enable/disable as well as language--- extensions enabled by pragma in the source.-parsePragmasIntoDynFlags :: DynFlags-                         -> ([Extension], [Extension])-                         -> FilePath-                         -> String-                         -> IO (Either String DynFlags)-parsePragmasIntoDynFlags flags (enable, disable) filepath str =-  catchErrors $ do-    let opts = getOptions flags (stringToStringBuffer str) filepath-    (flags, _, _) <- parseDynamicFilePragma flags opts-    let flags' =  foldl' xopt_set flags enable-    let flags'' = foldl' xopt_unset flags' disable-    return $ Right flags''-  where-    catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)-    catchErrors act = handleGhcException reportErr-                        (handleSourceError reportErr act)-    reportErr e = return $ Left (show e)--parseFileGhcLib ::-  FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))-parseFileGhcLib filename str flags =-  Lexer.unP Parser.parseModule parseState-  where-    location = mkRealSrcLoc (mkFastString filename) 1 1-    buffer = stringToStringBuffer $-              if takeExtension filename /= ".lhs" then str else unlit filename str-    parseState = mkPState flags buffer location-------------------------------------------------------------------------- The following functions are from--- https://github.com/pepeiborra/haskell-src-exts-util ("Utility code--- for working with haskell-src-exts") rewritten for GHC parse trees--- (of which at least one of them came from this project originally).---- | 'isAtom e' if 'e' requires no bracketing ever.-isAtom :: (p ~ GhcPass pass) => HsExpr p -> Bool-isAtom x = case x of-  HsVar {}          -> True-  HsUnboundVar {}   -> True-  HsRecFld {}       -> True-  HsOverLabel {}    -> True-  HsIPVar {}        -> True-  HsPar {}          -> True-  SectionL {}       -> True-  SectionR {}       -> True-  ExplicitTuple {}  -> True-  ExplicitSum {}    -> True-  ExplicitList {}   -> True-  RecordCon {}      -> True-  RecordUpd {}      -> True-  ArithSeq {}       -> True-  HsBracket {}      -> True-  HsRnBracketOut {} -> True-  HsTcBracketOut {} -> True-  HsSpliceE {}      -> True-  HsLit _ x     | not $ isNegativeLit x     -> True-  HsOverLit _ x | not $ isNegativeOverLit x -> True-  _                 -> False-  where-    isNegativeLit (HsInt _ i) = il_neg i-    isNegativeLit (HsRat _ f _) = fl_neg f-    isNegativeLit (HsFloatPrim _ f) = fl_neg f-    isNegativeLit (HsDoublePrim _ f) = fl_neg f-    isNegativeLit (HsIntPrim _ x) = x < 0-    isNegativeLit (HsInt64Prim _ x) = x < 0-    isNegativeLit (HsInteger _ x _) = x < 0-    isNegativeLit _ = False--    isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i-    isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f-    isNegativeOverLit _ = False---- | 'addParen e' wraps 'e' in parens.-addParen :: (p ~ GhcPass pass) => HsExpr p -> HsExpr p-addParen e = HsPar noExt (noLoc e)+import GHC.Util.View+import GHC.Util.FreeVars+import GHC.Util.ApiAnnotation+import GHC.Util.HsExpr+import GHC.Util.HsDecl+import GHC.Util.SrcLoc+import GHC.Util.DynFlags+import GHC.Util.Scope+import GHC.Util.Unify --- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.-paren :: (p ~ GhcPass pass) => HsExpr GhcPs -> HsExpr GhcPs-paren x-  | isAtom x  = x-  | otherwise = addParen x+import Language.Haskell.GhclibParserEx.GHC.Parser (parseFile)+import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags)+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable --- | 'isApp e' if 'e' is a (regular) application.-isApp :: (p ~ GhcPass pass) => HsExpr p -> Bool-isApp x = case x of-  HsApp {}  -> True-  _         -> False+import GHC.Hs+import GHC.Parser.Lexer+import GHC.Types.SrcLoc+import GHC.Driver.Session+import GHC.Data.FastString --- | 'isOpApp e' if 'e' is an operator application.-isOpApp :: (p ~ GhcPass pass) => HsExpr p -> Bool-isOpApp x = case x of-  OpApp {}   -> True-  _          -> False+import System.FilePath+import Language.Preprocessor.Unlit --- | 'isAnyApp e' if 'e' is either an application or operator--- application.-isAnyApp :: (p ~ GhcPass pass) => HsExpr p -> Bool-isAnyApp x = isApp x || isOpApp x+fileToModule :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))+fileToModule filename str flags =+  parseFile filename flags+    (if takeExtension filename /= ".lhs" then str else unlit filename str) --- | 'isDot e'  if 'e' is the unqualifed variable '.'.-isDot :: HsExpr GhcPs -> Bool-isDot x-  | HsVar _ (L _ ident) <- x-    , ident == mkVarUnqual (fsLit ".") = True-  | otherwise                          = False+{-# 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+      )) --- | 'isSection e' if 'e' is a section.-isSection :: (p ~ GhcPass pass) => HsExpr p -> Bool-isSection x = case x of-  SectionL {} -> True-  SectionR {} -> True-  _           -> False+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 _) =+  ( "no-span"+  , -1+  , -1+  , -1+  , -1+  ) --- | 'isDotApp e' if 'e' is dot application.-isDotApp :: HsExpr GhcPs -> Bool-isDotApp (OpApp _ _ (L _ op) _) = isDot op-isDotApp _ = False+{-# COMPLETE SrcLoc #-}+pattern SrcLoc :: String -> Int -> Int -> SrcLoc+pattern SrcLoc+  { srcFilename+  , srcLine+  , srcColumn+  }+  <-+    (toOldeLoc ->+      ( srcFilename+      , srcLine+      , srcColumn+      )) --- | All available GHC extensions-enumerateExtensions :: [Extension]--- 'Cpp' are the first and last cases of type 'Extension' in--- 'libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs'. When we are--- on a version of GHC that has MR--- https://gitlab.haskell.org/ghc/ghc/merge_requests/826, we can--- replace them with 'minBound' and 'maxBound' respectively.-enumerateExtensions = [Cpp .. StarIsType]+toOldeLoc :: SrcLoc -> (String, Int, Int)+toOldeLoc (RealSrcLoc loc _) =+  ( unpackFS $ srcLocFile loc+  , srcLocLine loc+  , srcLocCol loc+  )+toOldeLoc (UnhelpfulLoc _) =+  ( "no-loc"+  , -1+  , -1+  ) --- | Parse a GHC extension-readExtension :: String -> Maybe Extension-readExtension x = Map.lookup x exts-  where exts = Map.fromList [(show x, x) | x <- [Cpp .. StarIsType]]+showSrcSpan :: SrcSpan -> String+showSrcSpan = unsafePrettyPrint
+ src/GHC/Util/ApiAnnotation.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ImportQualifiedPost #-}++module GHC.Util.ApiAnnotation (+    comment_+  , commentText+  , GHC.Util.ApiAnnotation.comments+  , isCommentMultiline+  , pragmas+  , flags+  , languagePragmas+  , mkFlags+  , mkLanguagePragmas+  , extensions+) where++import GHC.LanguageExtensions.Type (Extension)+import GHC.Parser.Annotation+import GHC.Hs.DocString+import GHC.Types.SrcLoc++import Language.Haskell.GhclibParserEx.GHC.Driver.Session++import Control.Applicative+import Data.List.Extra+import Data.Maybe+import Data.Set qualified as Set++trimCommentStart :: String -> String+trimCommentStart s+    | Just s <- stripPrefix "{-" s = s+    | Just s <- stripPrefix "--" s = s+    | otherwise = s++trimCommentEnd :: String -> String+trimCommentEnd s+    | Just s <- stripSuffix "-}" s = s+    | otherwise = s++trimCommentDelims :: String -> String+trimCommentDelims = trimCommentEnd . trimCommentStart++-- | A comment as a string.+comment_ :: LEpaComment -> String+comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds+comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s+comment_ (L _ (EpaComment (EpaLineComment s) _)) = s+comment_ (L _ (EpaComment (EpaBlockComment s) _)) = s++-- | The comment string with delimiters removed.+commentText :: LEpaComment -> String+commentText = trimCommentDelims . comment_++-- | Total replacement for the partial `GHC.Parser.Annotation.comments` field of+-- `EpAnn`+comments :: EpAnn ann -> EpAnnComments+comments EpAnn{ GHC.Parser.Annotation.comments = result } = result++isCommentMultiline :: LEpaComment -> Bool+isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True+isCommentMultiline _ = False++-- Pragmas have the form @{-# ...#-}@.+pragmas :: EpAnnComments -> [(LEpaComment, String)]+pragmas x =+  -- 'EpaAnnComments' stores pragmas in reverse order to how they were+  -- encountered in the source file with the last at the head of the+  -- list (makes sense when you think about it).+  reverse+    [ (c, s) |+        c@(L _ (EpaComment (EpaBlockComment comm) _)) <- priorComments x+      , let body = trimCommentDelims comm+      , Just rest <- [stripSuffix "#" =<< stripPrefix "#" body]+      , let s = trim rest+    ]++-- All the extensions defined to be used.+extensions :: EpAnnComments -> Set.Set Extension+extensions = Set.fromList . concatMap (mapMaybe readExtension . snd) . languagePragmas . pragmas++-- Utility for a case insensitive prefix strip.+stripPrefixCI :: String -> String -> Maybe String+stripPrefixCI pref str =+  let pref' = lower pref+      (str_pref, rest) = splitAt (length pref') str+  in if lower str_pref == pref' then Just rest else Nothing++-- Flags. The first element of the pair is the comment that+-- sets the flags enumerated in the second element of the pair.+flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])]+flags ps =+  -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but+  -- this is deprecated).+  [(c, opts) | (c, s) <- ps+             , Just rest <- [stripPrefixCI "OPTIONS_GHC " s+                             <|> stripPrefixCI "OPTIONS " s]+             , let opts = words rest]++-- Language pragmas. The first element of the+-- pair is the (located) annotation comment that enables the+-- pragmas enumerated by the second element of the pair.+languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])]+languagePragmas ps =+  [(c, exts) | (c, s) <- ps+             , Just rest <- [stripPrefixCI "LANGUAGE " s]+             , let exts = map trim (splitOn "," rest)]++-- Given a list of flags, make a GHC options pragma.+mkFlags :: NoCommentsLocation -> [String] -> LEpaComment+mkFlags anc flags =+  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc)++mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment+mkLanguagePragmas anc exts =+  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)
+ src/GHC/Util/Brackets.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-}++module GHC.Util.Brackets (Brackets(..), isApp,isOpApp,isAnyApp) where++import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Refact.Types++class Brackets a where+  remParen :: a -> Maybe a -- Remove one paren or nothing if there is no paren.+  addParen :: a -> a -- Write out a paren.+  -- | Is this item lexically requiring no bracketing ever i.e. is+  -- totally atomic.+  isAtom :: a -> Bool+  -- | Is the child safe free from brackets in the parent+  -- position. Err on the side of caution, True = don't know.+  needBracket :: Int -> a -> a -> Bool+  findType :: a -> RType++instance Brackets (LocatedA (HsExpr GhcPs)) where+  -- When GHC parses a section in concrete syntax, it will produce an+  -- 'HsPar (Section[L|R])'. There is no concrete syntax that will+  -- result in a "naked" section. Consequently, given an expression,+  -- when stripping brackets (c.f. 'Hint.Brackets), don't remove the+  -- paren's surrounding a section - they are required.+  remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing+  remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing+  remParen (L _ (HsPar _ x)) = Just x+  remParen _ = Nothing++  addParen = nlHsPar++  isAtom (L _ x) = case x of+      HsVar{} -> True+      HsUnboundVar{} -> True+      -- Only relevant for OverloadedRecordDot extension+      HsGetField{} -> True+      HsOverLabel{} -> True+      HsIPVar{} -> True+      -- Note that sections aren't atoms (but parenthesized sections are).+      HsPar{} -> True+      ExplicitTuple{} -> True+      ExplicitSum{} -> True+      ExplicitList{} -> True+      RecordCon{} -> True+      RecordUpd{} -> True+      ArithSeq{}-> True+      HsTypedBracket{} -> True+      HsUntypedBracket{} -> True+      -- HsSplice might be $foo, where @($foo) would require brackets,+      -- but in that case the $foo is a type, so we can still mark Splice as atomic+      HsTypedSplice{} -> True+      HsUntypedSplice{} -> True+      HsOverLit _ x | not $ isNegativeOverLit x -> True+      HsLit _ x     | not $ isNegativeLit x     -> True+      _  -> False+      where+        isNegativeLit (HsInt _ i) = il_neg i+        isNegativeLit (HsRat _ f _) = fl_neg f+        isNegativeLit (HsFloatPrim _ f) = fl_neg f+        isNegativeLit (HsDoublePrim _ f) = fl_neg f+        isNegativeLit (HsIntPrim _ x) = x < 0+        isNegativeLit (HsInt64Prim _ x) = x < 0+        isNegativeLit (HsInteger _ x _) = x < 0+        isNegativeLit _ = False+        isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i+        isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f+        isNegativeOverLit _ = False+  isAtom _ = False -- '{-# COMPLETE L #-}'++  needBracket i parent child -- Note: i is the index in children, not in the AST.+     | isAtom child = False+     | isSection parent, L _ HsApp{} <- child = False+     | L _ OpApp{} <- parent, L _ HsApp{} <- child, i /= 0 || isAtomOrApp 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++  findType _ = Expr++-- | Am I an HsApp such that having me in an infix doesn't require brackets.+--   Before BlockArguments that was _all_ HsApps. Now, imagine:+--+--   (f \x -> x) *> ...+--   (f do x) *> ...+isAtomOrApp :: LocatedA (HsExpr GhcPs) -> Bool+isAtomOrApp x | isAtom x = True+isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x+isAtomOrApp _ = False++instance Brackets (LocatedA (Pat GhcPs)) where+  remParen (L _ (ParPat _ x)) = Just x+  remParen _ = Nothing++  addParen = nlParPat++  isAtom (L _ x) = case x of+    ParPat{} -> True+    TuplePat{} -> True+    ListPat{} -> True+    -- This is technically atomic, but lots of people think it shouldn't be+    ConPat _ _ RecCon{} -> False+    -- Before we only checked args, but not type args, resulting in a+    -- false positive for things like (Proxy @a)+    ConPat _ _ (PrefixCon [] []) -> True+    VarPat{} -> True+    WildPat{} -> True+    SumPat{} -> True+    AsPat{} -> True+    SplicePat{} -> True+    LitPat _ x | not $ isSignedLit x -> True+    _ -> False+    where+      isSignedLit HsInt{} = True+      isSignedLit HsIntPrim{} = True+      isSignedLit HsInt64Prim{} = True+      isSignedLit HsInteger{} = True+      isSignedLit HsRat{} = True+      isSignedLit HsFloatPrim{} = True+      isSignedLit HsDoublePrim{} = True+      isSignedLit _ = False+  isAtom _ = False -- '{-# COMPLETE L #-}'++  needBracket _ parent child+    | isAtom child = False+    | L _ TuplePat{} <- parent = False+    | L _ ListPat{} <- parent = False+    | otherwise = True++  findType _ = Pattern++instance Brackets (LocatedA (HsType GhcPs)) where+  remParen (L _ (HsParTy _ x)) = Just x+  remParen _ = Nothing+  addParen e = noLocA $ HsParTy noAnn e++  isAtom (L _ x) = case x of+      HsParTy{} -> True+      HsTupleTy{} -> True+      HsListTy{} -> True+      HsExplicitTupleTy{} -> True+      HsExplicitListTy{} -> True+      HsTyVar{} -> True+      HsSumTy{} -> True+      HsWildCardTy{} -> True+      -- HsSpliceTy{} is not atomic, because of @($foo)+      _ -> False+  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+    | 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++  findType _ = Type
+ src/GHC/Util/DynFlags.hs view
@@ -0,0 +1,14 @@+module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where++import GHC.Driver.Session+import Language.Haskell.GhclibParserEx.GHC.Settings.Config++-- The list of default enabled extensions is empty. This is because:+-- the extensions to enable/disable are set exclusively in+-- 'parsePragmasIntoDynFlags' based solely on the parse flags+-- (and source level annotations).+baseDynFlags :: DynFlags+baseDynFlags = defaultDynFlags fakeSettings++initGlobalDynFlags :: IO ()+initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags
+ src/GHC/Util/FreeVars.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Util.FreeVars (+    vars, varss, pvars,+    Vars (..), FreeVars(..) , AllVars (..)+  ) where++import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import GHC.Types.Name+import GHC.Hs+import GHC.Types.SrcLoc++import Data.Generics.Uniplate.DataOnly+import Data.Monoid+import Data.Semigroup+import Data.List.Extra+import Data.Set (Set)+import Data.Set qualified as Set+import Prelude++( ^+ ) :: Set OccName -> Set OccName -> Set OccName+( ^+ ) = Set.union+( ^- ) :: Set OccName -> Set OccName -> Set OccName+( ^- ) = Set.difference++-- See [Note : Space leaks lurking here?] below.+data Vars = Vars{bound :: Set OccName, free :: Set OccName}++-- Useful for debugging.+instance Show Vars where+  show (Vars bs fs) = "bound : " +++    show (map occNameString (Set.toList bs)) +++    ", free : " ++ show (map occNameString (Set.toList fs))++instance Semigroup Vars where+    Vars x1 x2 <> Vars y1 y2 = Vars (x1 ^+ y1) (x2 ^+ y2)++instance Monoid Vars where+    mempty = Vars Set.empty Set.empty+    mconcat vs = Vars (Set.unions $ map bound vs) (Set.unions $ map free vs)++-- A type `a` is a model of `AllVars a` if exists a function+-- `allVars` for producing a pair of the bound and free variable+-- sets in a value of `a`.+class AllVars a where+    -- | Return the variables, erring on the side of more free+    -- variables.+    allVars :: a -> Vars++-- A type `a` is a model of `FreeVars a` if exists a function+-- `freeVars` for producing a set of free variables of a value of+-- `a`.+class FreeVars a where+    -- | Return the variables, erring on the side of more free+    -- variables.+    freeVars :: a -> Set OccName++-- Trivial instances.+instance AllVars Vars  where allVars = id+instance FreeVars (Set OccName) where freeVars = id+-- [Note : Space leaks lurking here?]+-- ==================================+-- We make use of `foldr`. @cocreature suggests we want bangs on `data+-- Vars` and replace usages of `mconcat` with `foldl`.+instance (AllVars a) => AllVars [a] where  allVars = mconcatMap allVars+instance (FreeVars a) => FreeVars [a] where  freeVars = Set.unions . map freeVars++-- Construct a `Vars` value with no bound vars.+freeVars_ :: (FreeVars a) => a -> Vars+freeVars_ = Vars Set.empty . freeVars++-- `inFree a b` is the set of free variables in a together with the+-- free variables in b not bound in a.+inFree :: (AllVars a, FreeVars b) => a -> b -> Set OccName+inFree a b = free aa ^+ (freeVars b ^- bound aa)+    where aa = allVars a++-- `inVars a b` is a value of `Vars_` with bound variables the union+-- of the bound variables of a and b and free variables the union+-- of the free variables of a and the free variables of b not+-- bound by a.+inVars :: (AllVars a, AllVars b) => a -> b -> Vars+inVars a b =+  Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa))+    where aa = allVars a+          bb = allVars b++-- Get an `OccName` out of a reader name.+unqualNames :: LocatedN RdrName -> [OccName]+unqualNames (L _ (Unqual x)) = [x]+unqualNames (L _ (Exact x)) = [nameOccName x]+unqualNames _ = []++instance FreeVars (LocatedA (HsExpr GhcPs)) where+  freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.+  freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [rdrNameOcc x] -- Unbound variable; also used for "holes".+  freeVars (L _ (HsLam _ LamSingle mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.+  freeVars (L _ (HsLam _ _ 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))) = snd $ foldl' alg mempty stmts -- Do block.+    where+      alg ::+        (Set OccName, Set OccName) ->+        LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))) ->+        (Set OccName, Set OccName)+      alg (accBound0, accFree0) stmt = (accBound, accFree)+        where+          accBound =+            accBound0+              ^+ ( case stmt of+                     L _ (BindStmt _ pat _) -> bound (allVars pat)+                     L _ (LetStmt _ binds) -> bound (allVars binds)+                     _ -> mempty+                 )+          accFree = accFree0 ^+ (free (allVars stmt) ^- accBound0)+  freeVars (L _ (RecordCon _ _ (HsRecFields _ flds _))) = Set.unions $ map freeVars flds -- Record construction.+  freeVars (L _ (RecordUpd _ e flds)) =+    case flds of+      RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs+      OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps+  freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.+  freeVars (L _ (HsTypedBracket _ e)) = freeVars e+  freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e+  freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]++  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 (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 (HsTupArg GhcPs) where+  freeVars (Present _ args) = freeVars args+  freeVars _ = mempty++instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where+   freeVars o@(L _ (HsFieldBind _ x _ True)) = Set.singleton $ occName $ unLoc $ foLabel $ unLoc x -- a pun+   freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x++instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where+  freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x++instance AllVars (LocatedA (Pat GhcPs)) where+  allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.+  allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.+  allVars (L _ (ConPat _ _ (RecCon (HsRecFields _ flds _)))) = allVars flds+  allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern.+  allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.+  allVars (L _ WildPat{}) = mempty -- Wildcard pattern.+  allVars (L _ LitPat{}) = mempty -- Literal pattern.+  allVars (L _ NPat{}) = mempty -- Natural pattern.+  allVars (L _ InvisPat {}) = mempty -- since ghc-9.10.1++  -- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).+  -- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.+  -- allVars p@CoPat{} = allVars $ children p -- Coercion pattern.+  -- allVars p@LazyPat{} = allVars $ children p -- Lazy pattern.+  -- allVars p@ParPat{} = allVars $ children p -- Parenthesized pattern.+  -- allVars p@BangPat{} = allVars $ children p -- Bang pattern.+  -- allVars p@ListPat{} = allVars $ children p -- Syntactic list.+  -- allVars p@TuplePat{} = allVars $ children p -- Tuple sub patterns.+  -- allVars p@SumPat{} = allVars $ children p -- Anonymous sum pattern.++  allVars p = allVars $ children p++instance AllVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where+   allVars (L _ (HsFieldBind _ _ x _)) = allVars x++instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where+  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_ (noLocA fmap_ :: LocatedA (HsExpr GhcPs)) -- Apply a function to a list of statements in order.+  allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars (unLoc stmts) -- A recursive binding for a group of arrows.+  allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it.++instance AllVars (HsLocalBinds GhcPs) where+  allVars (HsValBinds _ (ValBinds _ binds _)) = allVars binds -- Value bindings.+  allVars (HsIPBinds _ (IPBinds _ binds)) = allVars binds -- Implicit parameter bindings.+  allVars EmptyLocalBinds{} =  mempty -- The case of no local bindings (signals the empty `let` or `where` clause).+  allVars _ = mempty -- extension points++instance AllVars (LocatedA (IPBind GhcPs)) where+  allVars (L _ (IPBind _ _ e)) = freeVars_ e++instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where+  allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (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 (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 _ (PatSynBind _ PSB{})) = mempty -- Come back to it.++instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where+  allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars ((unLoc . m_pats) m)) (allVars (m_grhss m))) ms+    where ms = map unLoc alts++instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where+  allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat GhcPs)) <> (allVars . unLoc) pats <> allVars grhss -- A pattern matching on an argument of a function binding.+  allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> (allVars . unLoc) pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.+  allVars (L _ (Match _ _ pats grhss)) = inVars ((allVars . unLoc) pats) (allVars grhss) -- Everything else.++instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where+  allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs))+  allVars ParStmtCtxt{} = mempty -- Come back to it.+  allVars TransStmtCtxt{}  = mempty -- Come back to it.+  allVars _ = mempty++instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where+  allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss)++instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where+  allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards++instance AllVars (LocatedA (HsDecl GhcPs)) where+  allVars (L l (ValD _ bind)) = allVars (L l bind :: LocatedA (HsBindLR GhcPs GhcPs))+  allVars _ = mempty+++vars :: FreeVars a => a -> [String]+vars = Set.toList . Set.map occNameString . freeVars++varss :: AllVars a => a -> [String]+varss = Set.toList . Set.map occNameString . free . allVars++pvars :: AllVars a => a -> [String]+pvars = Set.toList . Set.map occNameString . bound . allVars
+ src/GHC/Util/HsDecl.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NamedFieldPuns #-}++module GHC.Util.HsDecl (declName,bindName)+where++import GHC.Hs+import GHC.Types.SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader++-- | @declName x@ returns the \"new name\" that is created (for+-- example a function declaration) by @x@.  If @x@ isn't a declaration+-- that creates a new name (for example an instance declaration),+-- 'Nothing' is returned instead.  This is useful because we don't+-- want to tell users to rename binders that they aren't creating+-- right now and therefore usually cannot change.+declName :: LHsDecl GhcPs -> Maybe String+declName (L _ x) = occNameStr <$> case x of+    TyClD _ FamDecl{tcdFam=FamilyDecl{fdLName}} -> Just $ unLoc fdLName+    TyClD _ SynDecl{tcdLName} -> Just $ unLoc tcdLName+    TyClD _ DataDecl{tcdLName} -> Just $ unLoc tcdLName+    TyClD _ ClassDecl{tcdLName} -> Just $ unLoc tcdLName+    ValD _ FunBind{fun_id}  -> Just $ unLoc fun_id+    ValD _ VarBind{var_id}  -> Just var_id+    ValD _ (PatSynBind _ PSB{psb_id}) -> Just $ unLoc psb_id+    SigD _ (TypeSig _ (x:_) _) -> Just $ unLoc x+    SigD _ (PatSynSig _ (x:_) _) -> Just $ unLoc x+    SigD _ (ClassOpSig _ _ (x:_) _) -> Just $ unLoc x+    ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name+    ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name+    _ -> Nothing+++bindName :: LHsBind GhcPs -> Maybe String+bindName (L _ FunBind{fun_id}) = Just $ rdrNameStr fun_id+bindName (L _ VarBind{var_id}) = Just $ occNameStr var_id+bindName _ = Nothing
+ src/GHC/Util/HsExpr.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module GHC.Util.HsExpr (+    dotApps, lambda+  , simplifyExp, niceLambda, niceLambdaR+  , Brackets(..)+  , rebracket1, appsBracket, transformAppsM, fromApps, apps, universeApps, universeParentExp+  , paren+  , replaceBranches+  , needBracketOld, transformBracketOld, fromParen1+  , allowLeftSection, allowRightSection+) where++import GHC.Hs+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Data.FastString+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence++import GHC.Util.Brackets+import GHC.Util.FreeVars+import GHC.Util.View++import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer.CPS++import Data.Data+import Data.Generics.Uniplate.DataOnly+import Data.List.Extra+import Data.Tuple.Extra+import Data.Maybe++import Refact (substVars, toSSA)+import Refact.Types hiding (SrcSpan, Match)+import Refact.Types qualified as R (SrcSpan)++import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader++-- | 'dotApp a b' makes 'a . b'.+dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+dotApp x y = noLocA $ OpApp noExtField x (noLocA $ HsVar noExtField (noLocA $ 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 = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))]))++-- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.+paren :: LHsExpr GhcPs -> LHsExpr GhcPs+paren x+  | isAtom x  = x+  | otherwise = addParen x++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) <- zipFrom 0 $ children p]+++apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs+apps = foldl1' mkApp where mkApp x y = noLocA (HsApp noExtField x y)++fromApps :: LHsExpr GhcPs  -> [LHsExpr GhcPs]+fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]+fromApps x = [x]++childrenApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]+childrenApps (L _ (HsApp _ x y)) = childrenApps x ++ [y]+childrenApps x = children x++universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]+universeApps x = x : concatMap universeApps (childrenApps x)++descendAppsM :: Monad m => (LHsExpr GhcPs  -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)+descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp noExtField x y) <$> descendAppsM f x <*> f y+descendAppsM f x = descendM f x++transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)+transformAppsM f x = f =<< descendAppsM (transformAppsM f) x++descendIndex :: Data a => (Int -> a -> a) -> a -> a+descendIndex f = fst . descendIndex' (\x a -> writer (f x a, ()))++descendIndex' :: (Data a, Monoid w) => (Int -> a -> Writer w a) -> a -> (a, w)+descendIndex' f x = runWriter $ flip evalStateT 0 $ flip descendM x $ \y -> do+    i <- get+    modify (+1)+    lift $ f i y++--  There are differences in pretty-printing between GHC and HSE. This+--  version never removes brackets.+descendBracket :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs+descendBracket op x = descendIndex g x+    where+        g i y = if a then f i b else b+            where (a, b) = op y+        f i y = if needBracket i x y then addParen y else y++-- Add brackets as suggested 'needBracket at 1-level of depth.+rebracket1 :: LHsExpr GhcPs -> LHsExpr GhcPs+rebracket1 = descendBracket (True, )++-- A list of application, with any necessary brackets.+appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs+appsBracket = foldl1 mkApp+  where mkApp x y = rebracket1 (noLocA $ HsApp noExtField x y)++simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs+-- Replace appliciations 'f $ x' with 'f (x)'.+simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar y))+simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =+  -- An expression of the form, 'let x = y in z'.+  case binds of+    [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ [L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]+         -- If 'x' is not in the free variables of 'y', beta-reduce to+         -- 'z[(y)/x]'.+      | occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->+          transform f z+          where f (view -> Var_ x') | occNameStr x == x' = paren y+                f x = x+    _ -> e+simplifyExp e = e++-- Rewrite '($) . b' as 'b'.+niceDotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+niceDotApp (L _ (HsVar _ (L _ r))) b | occNameStr r == "$" = b+niceDotApp a b = dotApp a b++-- Generate a lambda expression but prettier if possible.+niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs+niceLambda ss e = fst (niceLambdaR ss e)-- We don't support refactorings yet.++allowRightSection :: String -> Bool+allowRightSection x = x `notElem` ["-","#"]+allowLeftSection :: String -> Bool+allowLeftSection x = x /= "#"++-- Implementation. Try to produce special forms (e.g. sections,+-- compositions) where we can.+niceLambdaR :: [String]+            -> LHsExpr GhcPs+            -> (LHsExpr GhcPs, R.SrcSpan -> [Refactoring R.SrcSpan])+-- Rewrite @\ -> 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+  = let res = nlHsPar $ noLocA $ SectionL noExtField e f+     in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)])++-- @\vs v -> f x v@ ==> @\vs -> f x@+niceLambdaR (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))+  | v == v'+  , vars f `disjoint` [v]+  = niceLambdaR vs f++-- @\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@(L _ (HsVar _ (L _ tag))) l r)+  | isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =+      let e = rebracket1 $ addParen (noLocA $ 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, \s -> [mkRefact subts s])+  where+    -- Factor the expression with respect to x.+    factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])+    factor (L _ (HsApp _ ini lst)) | view lst == Var_ x = Just (ini, [ini])+    factor (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 (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 (L _ (HsPar _ y@(L _ HsApp{}))) = factor y+    factor _ = Nothing+    mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan+    mkRefact subts s =+      let tempSubts = zipWith (\a b -> (a, toSSA b)) substVars 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] =+      ( gen op+      , \s -> [Replace Expr s [("x", toSSA op)] (unsafePrettyPrint $ gen (strToVar "x"))]+      )+  where+    gen :: LHsExpr GhcPs -> LHsExpr GhcPs+    gen = noLocA . HsApp noExtField (strToVar "flip")+        . if isAtom op then id else addParen++-- We're done factoring, but have no variables left, so we shouldn't make a lambda.+-- @\ -> e@ ==> @e@+niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"])+-- Base case. Just a good old fashioned lambda.+niceLambdaR ss e =+  let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)+      grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}+      match = noLocA $ Match {m_ext=noExtField, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)+      matchGroup = MG {mg_ext=Generated OtherExpansion SkipPmc, mg_alts=noLocA [match]}+  in (noLocA $ HsLam noAnn LamSingle 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 (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noAnn a b c))++replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =+  (concatMap f bs, L s . HsCase noAnn a . MG (Generated OtherExpansion SkipPmc). L l . g bs)+  where+    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]+    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 (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =+      L s1 (Match noExtField CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn 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"++replaceBranches x = ([], \[] -> x)+++-- Like needBracket, but with a special case for 'a . b . b', which was+-- removed from haskell-src-exts-util-0.2.2.+needBracketOld :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool+needBracketOld i parent child+  | isDotApp parent, isDotApp child, i == 2 = False+  | otherwise = needBracket i parent child++transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))+                    -> LHsExpr GhcPs+                    -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))+transformBracketOld op = first snd . g+  where+    g = first f . descendBracketOld g+    f x = maybe (False, x) (True, ) (op x)++-- Descend, and if something changes then add/remove brackets+-- appropriately. Returns (suggested replacement, (refactor template, no bracket vars)),+-- where "no bracket vars" is a list of substitution variables which, when expanded,+-- should have the brackets stripped.+descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))+                  -> LHsExpr GhcPs+                  -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))+descendBracketOld op x = (descendIndex g1 x, descendIndex' g2 x)+  where+    g i y = if a then (f1 i b z w, f2 i b z w) else (b, (z, w))+      where ((a, b), (z, w)) = op y++    g1 a b = fst (g a b)+    g2 a b = writer $ snd (g a b)++    f i (L _ (HsPar _ y)) z w+      | not $ needBracketOld i x y = (y, removeBracket z)+      where+        -- If the template expr is a Var, record it so that we can remove the brackets+        -- later when expanding it. Otherwise, remove the enclosing brackets (if any).+        removeBracket = \case+          var@(L _ HsVar{}) -> (z, varToStr var : w)+          other -> (fromParen z, w)+    f i y z w+      | needBracketOld i x y = (addParen y, (addParen z, w))+      -- https://github.com/mpickering/apply-refact/issues/7+      | isOp y = (y, (addParen z, w))+    f _ y z w = (y, (z, w))++    f1 a b c d = fst (f a b c d)+    f2 a b c d = snd (f a b c d)++    isOp = \case+      L _ (HsVar _ (L _ name)) -> isSymbolRdrName name+      _ -> False++fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen1 x = fromMaybe x $ remParen x
+ src/GHC/Util/Scope.hs view
@@ -0,0 +1,142 @@++{-# Language ViewPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.Scope (+   Scope+  ,scopeCreate,scopeMatch,scopeMove,possModules+) where++import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Data.FastString+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import GHC.Types.PkgQual++import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable++import Data.List.Extra+import Data.Maybe+import Data.Bifunctor++-- A scope is a list of import declarations.+newtype Scope = Scope [LImportDecl GhcPs]+               deriving (Monoid, Semigroup)++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 (L _ x) =+      case ideclPkgQual x of+        RawPkgQual s -> Just s+        NoRawPkgQual -> Nothing++    -- The import declarations contained by the module 'xs'.+    res :: [LImportDecl GhcPs]+    res = [x | x <- hsmodImports xs+             , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint") Nothing)+          ]++    -- Mock up an import declaration corresponding to 'import Prelude'.+    prelude :: LImportDecl GhcPs+    prelude = noLocA $ simpleImportDecl (mkModuleName "Prelude")++    -- Predicate to test for a 'Prelude' import declaration.+    isPrelude :: LImportDecl GhcPs -> Bool+    isPrelude (L _ x) = moduleNameString (unLoc (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, LocatedN RdrName) -> (Scope, LocatedN 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 (possModules a x `disjointOrd` 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, LocatedN RdrName) -> Scope -> LocatedN RdrName+scopeMove (a, x@(fromQual -> Just name)) (Scope b) = case imps of+  [] | -- If `possModules a x` includes Prelude, but `b` does not contain any module that may import `x`,+       -- then unqualify `x` and assume that it is from Prelude (#1298).+       any (\(L _ x) -> (moduleNameString . fst <$> isQual_maybe x) == Just "Prelude") real -> unqual x+     | otherwise -> headDef x real+  imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLocA $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name+        | otherwise -> unqual x+  where+    real :: [LocatedN RdrName]+    real = [noLocA $ mkRdrQual m name | m <- possModules a x]++    imps :: [ImportDecl GhcPs]+    imps = [unLoc i | r <- real, i <- b, possImport i r /= NotImported]+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.+-- 'prelude' is added to the result, unless we are certain which module a name is from (#1298).+possModules :: Scope -> LocatedN RdrName -> [ModuleName]+possModules (Scope is) x =+    [prelude | prelude `notElem` map fst res, not (any snd res)] ++ fmap fst res+  where+    -- The 'Bool' signals whether we are certain that 'x' is imported from the module.+    res0, res :: [(ModuleName, Bool)]+    res0 = [ (unLoc $ ideclName $ unLoc i, isImported == Imported)+           | i <- is, let isImported = possImport i x, isImported /= NotImported ]++    res | isSpecial x = [(mkModuleName "", True)]+        | L _ (Qual mod _) <- x = [(mod, True) | null res0] ++ res0+        | otherwise = res0++    prelude = mkModuleName "Prelude"++data IsImported = Imported | PossiblyImported | NotImported  deriving (Eq)++-- Determine if 'x' could possibly lie in the module named by the+-- import declaration 'i'.+possImport :: LImportDecl GhcPs -> LocatedN RdrName -> IsImported+possImport i n | isSpecial n = NotImported+possImport (L _ i) (L _ (Qual mod x)) =+  if mod `elem` ms && NotImported /= possImport (noLocA i{ideclQualified=NotQualified}) (noLocA $ mkRdrUnqual x)+    then Imported+    else NotImported+  where ms = map unLoc $ ideclName i : maybeToList (ideclAs i)+possImport (L _ i) (L _ (Unqual x)) =+  if ideclQualified i == NotQualified+    then maybe PossiblyImported (f . first (== EverythingBut)) (ideclImportList i)+    else NotImported+  where+    f :: (Bool, LocatedLI [LocatedA (IE GhcPs)]) -> IsImported+    f (hide, L _ xs)+      | hide = if Just True `elem` ms then NotImported else PossiblyImported+      | Just True `elem` ms = Imported+      | Nothing `elem` ms = PossiblyImported+      | otherwise = NotImported+      where ms = map g xs++    tag :: String+    tag = occNameString x++    g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'?+    g (L _ (IEVar _ y _)) = Just $ tag == unwrapName y+    g (L _ (IEThingAbs _ y _)) = Just $ tag == unwrapName y+    g (L _ (IEThingAll _ y _)) = if tag == unwrapName y then Just True else Nothing+    g (L _ (IEThingWith _ y _ ys _)) = Just $ tag `elem` unwrapName y : map unwrapName ys+    g _ = Just False++    unwrapName :: LIEWrappedName GhcPs -> String+    unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))+possImport _ _ = NotImported
+ src/GHC/Util/SrcLoc.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.SrcLoc (+    getAncLoc+  , stripLocs+  , SrcSpanD(..)+  ) where++import GHC.Parser.Annotation+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Data.Strict qualified++import Data.Default+import Data.Data+import Data.Generics.Uniplate.DataOnly++-- Get the 'SrcSpan' out of a value located by an 'NoCommentsLocation'+-- (e.g. comments).+getAncLoc :: GenLocated NoCommentsLocation a -> SrcSpan+getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.epaLocationRealSrcSpan (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing++-- 'stripLocs x' is 'x' with all contained source locs replaced by+-- 'noSrcSpan'.+stripLocs :: Data from => from -> from+stripLocs =+  transformBi (const dummySpan) . transformBi (const noSrcSpan)+  where+    dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+    dummySpan = mkRealSrcSpan dummyLoc dummyLoc++-- TODO (2020-10-03, SF): Maybe move the following definitions down to+-- ghc-lib-parser at some point.++-- 'Duplicates.hs' requires 'SrcSpan' be in 'Default' and 'Ord'.+newtype SrcSpanD = SrcSpanD SrcSpan+  deriving (Outputable, Eq)+instance Default SrcSpanD where def = SrcSpanD noSrcSpan++newtype FastStringD = FastStringD FastString+  deriving Eq+compareFastStrings (FastStringD f) (FastStringD g) =+  lexicalCompareFS f g+instance Ord FastStringD where compare = compareFastStrings++-- SrcSpan no longer provides 'Ord' so we are forced to roll our own.+--+-- Note: This implementation chooses that any span compares 'EQ to an+-- 'UnhelpfulSpan'. Ex falso quodlibet!+compareSrcSpans (SrcSpanD a) (SrcSpanD b) =+  case a of+    RealSrcSpan a1 _ ->+      case b of+        RealSrcSpan b1 _ ->+          a1 `compareRealSrcSpans` b1+        _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans"+    _ -> EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans"+compareRealSrcSpans a b =+  let (a1, a2, a3, a4, a5) = (LexicalFastString (srcSpanFile a), srcSpanStartLine a, srcSpanStartCol a, srcSpanEndLine a, srcSpanEndCol a)+      (b1, b2, b3, b4, b5) = (LexicalFastString (srcSpanFile b), srcSpanStartLine b, srcSpanStartCol b, srcSpanEndLine b, srcSpanEndCol b)+  in compare (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)+instance Ord SrcSpanD where compare = compareSrcSpans
+ src/GHC/Util/Unify.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}+{-# LANGUAGE DataKinds #-}++module GHC.Util.Unify(+    Subst(..), fromSubst,+    validSubst, removeParens, substitute,+    unifyExp+    ) where++import Control.Applicative+import Control.Monad+import Data.Generics.Uniplate.DataOnly+import Data.Char+import Data.Data+import Data.List.Extra+import Util++import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Utils.Outputable hiding ((<>))+import GHC.Types.Name.Reader++import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import GHC.Util.HsExpr+import GHC.Util.View+import Data.Maybe+import GHC.Data.FastString++isUnifyVar :: String -> Bool+isUnifyVar [x] = x == '?' || isAlpha x+isUnifyVar [] = False+isUnifyVar xs = all (== '?') xs++---------------------------------------------------------------------+-- SUBSTITUTION DATA TYPE++-- 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, Functor)++-- Unpack the substitution.+fromSubst :: Subst a -> [(String, a)]+fromSubst (Subst xs) = xs++instance Outputable a => Show (Subst a) where+    show (Subst xs) = unlines [a ++ " = " ++ unsafePrettyPrint b | (a,b) <- xs]++-- Check the unification is valid and simplify it.+validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)+validSubst eq = fmap Subst . mapM f . groupSort . fromSubst+    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++-- Perform a substitution.+-- Returns (suggested replacement, (refactor template, no bracket vars)). It adds/removes brackets+-- for both the suggested replacement and the refactor template appropriately. The "no bracket vars"+-- is a list of substitution variables which, when expanded, should have the brackets stripped.+--+-- Examples:+--   (traverse foo (bar baz), (traverse f (x), []))+--   (zipWith foo bar baz, (f a b, [f]))+substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))+substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ+  where+    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)+    -- Variables.+    exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind+    -- Operator applications.+    exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))+      | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noExtField lhs y rhs))+    -- Left sections.+    exp (L loc (SectionL _ exp (L _ (HsVar _ x))))+      | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y))+    -- Right sections.+    exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))+      | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR noExtField y exp))+    exp _ = Nothing++    pat :: LPat GhcPs -> LPat GhcPs+    -- Pattern variables.+    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 (L _ (HsTyVar _ _ x))+      | Just (L _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr x) bind = y+    typ x = x :: LHsType GhcPs+++---------------------------------------------------------------------+-- UNIFICATION++type NameMatch = LocatedN RdrName -> LocatedN RdrName -> Bool++-- | Unification, obeys the property that if @unify a b = s@, then+-- @substitute s a = b@.+unify' :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst (LHsExpr GhcPs))+unify' nm root x y+    | Just (x, y) <- cast (x, y) = unifyExp' nm root x y+    | Just (x, y) <- cast (x, y) = unifyPat' nm x y+    | Just (x, y) <- cast (x, y) = unifyType' nm x y+    | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing++    -- We need some type magic to reduce this.+    | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty+    | Just (x :: EpAnn AnnContext) <- cast x = Just mempty+    | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty+    | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty+    | Just (x :: EpAnn (AnnList [EpToken ","])) <- cast x = Just mempty+    | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty+    | Just (x :: EpAnn AnnParen) <- cast x = Just mempty+    | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty+    | Just (x :: EpAnn AnnProjection) <- cast x = Just mempty+    | Just (x :: EpAnn AnnsIf) <- cast x = Just mempty+    | Just (x :: EpAnn AnnSig) <- cast x = Just mempty+    | Just (x :: EpAnn AnnsModule) <- cast x = Just mempty+    | Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty+    | Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty+    | Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty+    | Just (x :: EpAnn EpAnnUnboundVar) <- cast x = Just mempty+    | Just (x :: EpAnn GrhsAnn) <- cast x = Just mempty+    | Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty+    | Just (x :: EpAnn NameAnn) <- cast x = Just mempty+    | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty+    | Just (x :: EpToken "let") <- cast x = Just mempty+    | Just (x :: EpToken "in") <- cast x = Just mempty+    | Just (x :: EpToken "@") <- cast x = Just mempty+    | Just (x :: EpToken "(") <- cast x = Just mempty+    | Just (x :: EpToken ")") <- cast x = Just mempty+    | Just (x :: EpToken "type") <- cast x = Just mempty+    | Just (x :: EpToken "%") <- cast x = Just mempty+    | Just (x :: EpToken "%1") <- cast x = Just mempty+    | Just (x :: EpToken "⊸") <- cast x = Just mempty+    | Just (x :: EpUniToken "->" "→") <- cast x = Just mempty+    | Just (x :: TokenLocation) <- cast y = Just mempty+    | Just (y :: SrcSpan) <- cast y = Just mempty++    | otherwise = unifyDef' nm x y++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 (noLocA (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 =+          if not root then+              -- 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.+              (, Nothing) <$> unifyExp' nm root x (noLocA (HsApp noExtField y11 (noLocA (HsApp noExtField y12 y2))))+          else do+              -- 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'.+              -- You can only add to extra if you are at the root (otherwise 'extra' has nowhere to go).+              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 $ noLocA (HsApp noExtField lhs2 rhs2)+    | isAmp op2 = unifyExp nm root x $ noLocA (HsApp noExtField rhs2 lhs2)+    | otherwise  = unifyExp nm root x $ noLocA (HsApp noExtField (noLocA (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2))+        where+          -- add parens around when desugaring the expression, if necessary+          addPar :: LHsExpr GhcPs -> LHsExpr GhcPs+          addPar x = if isAtom x then x else addParen x++unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y++isAmp :: LHsExpr GhcPs -> Bool+isAmp (L _ (HsVar _ x)) = rdrNameStr x == "&"+isAmp _ = False++-- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong+noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))+noExtra (Just (x, Nothing)) = Just x+noExtra _ = Nothing++-- 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+-- 'readRule' (Bug #570).+unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs))+-- Don't substitute for type apps, since no one writes rules imagining+-- they exist.+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++-- Brackets are not added when expanding '$' in user code, so tolerate+-- them in the match even if they aren't in the user code.+-- Also, allow the user to put in more brackets than they strictly need (e.g. with infix).+unifyExp' nm root x y | not root, isJust x2 || isJust y2 = unifyExp' nm root (fromMaybe x x2) (fromMaybe y y2)+    where+        -- Make sure we deal with the weird brackets that can't be removed around sections+        x2 = remParen x+        y2 = remParen y++unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr -> v))) rhs1))+                  y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) =+  noExtra $ 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 (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++unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) =+  noExtra $ unifyExp nm root x y++unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) =+  noExtra $ unifyExp nm root x y++unifyExp' nm root (L _ (HsUntypedBracket _ (VarBr _ b0 (occNameStr . unLoc -> v1))))+                  (L _ (HsUntypedBracket _ (VarBr _ b1 (occNameStr . unLoc -> v2))))+    | b0 == b1 && isUnifyVar v1 = Just (Subst [(v1, strToVar v2)])++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 (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 (L _ (VarPat _ x)) (L _ (VarPat _ y)) =+  Just $ Subst [(rdrNameStr x, strToVar(rdrNameStr y))]+unifyPat' nm (L _ (VarPat _ x)) (L _ (WildPat _)) =+  let s = rdrNameStr x in Just $ Subst [(s, strToVar("_" ++ s))]+unifyPat' nm (L _ (ConPat _ x _)) (L _ (ConPat _ 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 (L loc (HsTyVar _ _ x)) y =+  let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs)+      unused = strToVar "__unused__"+      appType = L loc (HsAppType noAnn unused wc)+ in Just $ Subst [(rdrNameStr x, appType)]+unifyType' nm x y = unifyDef' nm x y
+ src/GHC/Util/View.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}++module GHC.Util.View (+   fromParen+  , View(..)+  , RdrName_(RdrName_), Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)+  , pattern SimpleLambda+) where++import GHC.Hs+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Types.Basic+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import GHC.Util.Brackets++fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)+fromParen x = maybe x fromParen $ remParen x++fromPParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs)+fromPParen (L _ (ParPat _ x)) = fromPParen x+fromPParen x = x++class View a b where+  view :: a -> b++data RdrName_ = NoRdrName_ | RdrName_ (LocatedN RdrName)+data Var_  = NoVar_ | Var_ String deriving Eq+data PVar_ = NoPVar_ | PVar_ String+data PApp_ = NoPApp_ | PApp_ String [LocatedA (Pat GhcPs)]+data App2  = NoApp2  | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))+data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs))++instance View (LocatedA (HsExpr GhcPs)) LamConst1 where+  view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])+    (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x+  view _ = NoLamConst1++instance View (LocatedA (HsExpr GhcPs)) RdrName_ where+    view (fromParen -> (L _ (HsVar _ name))) = RdrName_ name+    view _ = NoRdrName_++instance View (LocatedA (HsExpr GhcPs)) Var_ where+    view (view -> RdrName_ name) = Var_ (rdrNameStr name)+    view _ = NoVar_++instance View (LocatedA (HsExpr GhcPs)) App2 where+  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 (LocatedA (Pat GhcPs)) PVar_ where+  view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameStr x+  view _ = NoPVar_++instance View (LocatedA (Pat GhcPs)) PApp_ where+  view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon _ args))) =+    PApp_ (occNameStr x) args+  view (fromPParen -> L _ (ConPat _ (L _ x) (InfixCon lhs rhs))) =+    PApp_ (occNameStr x) [lhs, rhs]+  view _ = NoPApp_++-- A lambda with no guards and no where clauses+pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)+pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
− src/Grep.hs 
@@ -1,31 +0,0 @@--module Grep(runGrep) where--import Hint.All-import Apply-import Config.Type-import HSE.All-import Control.Monad-import Data.List-import Util-import Idea---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 rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) 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 []-            Right (ModuleEx (m, c) _) ->-                forM_ (applyHints [] rule [(m, c)]) $ \i ->-                    print i{ideaHint="", ideaTo=Nothing}
src/HLint.hs view
@@ -1,43 +1,44 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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.Directory import System.Exit import System.IO.Extra import System.Time.Extra import Data.Tuple.Extra+import Data.Bifunctor (bimap) import Prelude -import Data.Version.Extra-import System.Process.Extra-import Data.Maybe-import System.Directory-import System.FilePath- import CmdLine import Config.Read import Config.Type import Config.Compute import Report+import Summary import Idea import Apply import Test.All import Hint.All-import Grep+import Refact import Timing-import Test.Proof import Parallel-import HSE.All+import GHC.All import CC+import EmbedData +import SARIF qualified  -- | This function takes a list of command line arguments, and returns the given hints. --   To see a list of arguments type @hlint --help@ at the console.@@ -53,61 +54,26 @@ --   on your server with untrusted input. hlint :: [String] -> IO [Idea] hlint args = do+    startTimings     cmd <- getCmd args-    case cmd of-        CmdMain{} -> do-            startTimings-            (time, xs) <- duration $ hlintMain args cmd-            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 ""+    timedIO "Initialise" "global flags" initGlobalDynFlags+    if cmdTest cmd then+        hlintTest cmd >> pure []+     else do+        (time, xs) <- duration $ hlintMain args cmd+        when (cmdTiming cmd) $ do+            printTimings+            putStrLn $ "Took " ++ showDuration time+        pure $ if cmdNoExitCode cmd then [] else xs  hlintTest :: Cmd -> IO ()-hlintTest cmd@CmdTest{..} =-    if not $ null cmdProof then do-        files <- cmdHintFiles cmd-        s <- readFilesConfig $ map (,Nothing) files-        let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports-        mapM_ (proof reps s) cmdProof-     else do-        failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints-        when (failed > 0) exitFailure+hlintTest cmd@CmdMain{..} = do+    failed <- test cmd (\args -> do errs <- hlint args; unless (null errs) $ exitWith $ ExitFailure 1) cmdDataDir cmdGivenHints+    when (failed > 0) exitFailure  cmdParseFlags :: Cmd -> ParseFlags cmdParseFlags cmd = parseFlagsSetLanguage (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd} -hlintGrep :: Cmd -> IO ()-hlintGrep cmd@CmdGrep{..} =-    if null cmdFiles then-        exitWithHelp-     else do-        files <- concatMapM (resolveFile cmd Nothing) cmdFiles-        if null files then-            error "No files found"-         else-            runGrep cmdPattern (cmdParseFlags cmd) files- withVerbosity :: Verbosity -> IO a -> IO a withVerbosity new act = do     old <- getVerbosity@@ -116,19 +82,42 @@ 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-        src <- readFile $ cmdDataDir </> "default.yaml"-        if null bad then putStr src else do-            let group1:groups = splitOn ["",""] $ lines src+        let bad = group $ sort $ map ideaHint ideas+        if null bad then putStr defaultYaml else do+            let group1:groups = splitOn ["",""] $ lines defaultYaml             let group2 = "# Warnings currently triggered by your code" :-                         ["- ignore: {name: " ++ show x ++ "}" | x <- bad]+                         ["- ignore: {name: " ++ show x ++ "} # "+                         ++ if null tl then "1 hint" else show (length xs) ++ " hints"+                         | xs@(x : tl) <- bad+                         ]+             putStr $ unlines $ intercalate ["",""] $ group1:group2:groups-        return []+        pure []+    | cmdGenerateMdSummary /= [] = do+        forM_ cmdGenerateMdSummary $ \file -> timedIO "Summary" file $ do+            whenNormal $ putStrLn $ "Writing Markdown summary to " ++ file ++ " ..."+            summary <- generateMdSummary . snd =<< readAllSettings args cmd+            writeFileBinary file summary+        pure []+    | cmdGenerateJsonSummary /= [] = do+        forM_ cmdGenerateJsonSummary $ \file -> timedIO "Summary" file $ do+            whenNormal $ putStrLn $ "Writing JSON summary to " ++ file ++ " ..."+            summary <- generateJsonSummary . snd =<< readAllSettings args cmd+            writeFileBinary file summary+        pure []+    | cmdGenerateExhaustiveConf /= [] = do+        forM_ cmdGenerateExhaustiveConf $ \severity ->+            let file = show severity ++ "-all.yaml"+             in timedIO "Exhaustive config file" file $ do+                whenNormal $ putStrLn $ "Writing " ++ show severity ++ "-all list to " ++ file ++ " ..."+                exhaustiveConfig <- generateExhaustiveConfig severity . snd =<< readAllSettings args cmd+                writeFileBinary file exhaustiveConfig+        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 =@@ -143,25 +132,32 @@  resolveFiles :: Cmd -> Maybe FilePath -> IO Cmd resolveFiles cmd@CmdMain{..} tmpFile = do+    -- if the first file is named 'lint' and there is no 'lint' file+    -- then someone is probably invoking the older hlint multi-mode command+    -- so skip it+    cmdFiles <- if not $ ["lint"] `isPrefixOf` cmdFiles then pure cmdFiles else do+        b <- doesDirectoryExist "lint"+        pure $ if b then cmdFiles else drop1 cmdFiles+     files <- concatMapM (resolveFile cmd tmpFile) cmdFiles     if null files         then error "No files found"         else pure cmd { cmdFiles = files }-resolveFiles cmd _ = pure cmd  readAllSettings :: [String] -> Cmd -> IO (Cmd, [Setting]) readAllSettings args1 cmd@CmdMain{..} = do     files <- cmdHintFiles cmd     settings1 <-         readFilesConfig $-        map (,Nothing) files-        ++ [("CommandLine.hs",Just x) | x <- cmdWithHints]+        files         ++ [("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]+    cmdThreads <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads+    cmd <- pure CmdMain {..}+    pure (cmd, settings1 ++ settings2 ++ settings3)     where         enableGroup groupName =             unlines@@ -171,16 +167,16 @@             ]  runHints :: [String] -> [Setting] -> Cmd -> IO [Idea]-runHints args settings cmd@CmdMain{..} = do-    j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads-    withNumCapabilities j $ do+runHints args settings cmd@CmdMain{..} =+    withNumCapabilities cmdThreads $ do         let outStrLn = whenNormal . putStrLn-        ideas <- getIdeas cmd settings-        ideas <- return $ if cmdShowAll then ideas else  filter (\i -> ideaSeverity i /= Ignore) ideas+        ideas <- filterIdeas <$> getIdeas cmd settings         if cmdJson then             putStrLn $ showIdeasJson ideas          else if cmdCC then             mapM_ (printIssue . fromIdea) ideas+         else if cmdSARIF then+            SARIF.printIdeas ideas          else if cmdSerialise then do             hSetBuffering stdout NoBuffering             print $ map (show &&& ideaRefactoring) ideas@@ -188,24 +184,31 @@             handleRefactoring ideas cmdFiles cmd          else do             usecolour <- cmdUseColour cmd-            showItem <- if usecolour then showANSI else return show+            let showItem = if usecolour then showIdeaANSI else show             mapM_ (outStrLn . showItem) ideas             handleReporting ideas cmd-        return ideas+        pure ideas+  where+    filteredSeverities+        | cmdShowAll = []+        | cmdIgnoreSuggestions = [Ignore, Suggestion]+        | otherwise = [Ignore]+    filterIdeas = filter (\i -> ideaSeverity i `notElem` filteredSeverities)  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 +-- #746: run refactor even if no hint, which ensures consistent output+-- whether there are hints or not. handleRefactoring :: [Idea] -> [String] -> Cmd -> IO ()-handleRefactoring [] _ _ = pure () -- No refactorings to apply handleRefactoring ideas files cmd@CmdMain{..} =     case cmdFiles of         [file] -> do@@ -215,9 +218,9 @@             let hints =  show $ map (show &&& ideaRefactoring) ideas             withTempFile $ \f -> do                 writeFile f hints-                exitWith =<< runRefactoring path file f cmdRefactorOptions-        _ -> error "Refactor flag can only be used with an individual file"-+                let ParseFlags{enabledExtensions, disabledExtensions} = cmdParseFlags cmd+                exitWith =<< runRefactoring path file f enabledExtensions disabledExtensions cmdRefactorOptions+        _ -> errorIO "Refactor flag can only be used with an individual file"  handleReporting :: [Idea] -> Cmd -> IO () handleReporting showideas cmd@CmdMain{..} = do@@ -226,31 +229,16 @@         outStrLn $ "Writing report to " ++ x ++ " ..."         writeReport cmdDataDir x showideas     unless cmdNoSummary $ do-        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+        let (nbErrors, nbHints) = bimap length length $ partition (\idea -> ideaSeverity idea == Error) showideas+        when (nbErrors > 0) (outStrLn $ formatOutput nbErrors "error")+        unless (nbErrors > 0 && nbHints == 0) (outStrLn $ formatOutput nbHints "hint") -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 ]+    where+        formatOutput :: Int -> String -> String+        formatOutput number name =+            if number == 0 then "No " ++ name ++ "s" else show number ++ " " ++ name ++ ['s' | number/=1]  evaluateList :: [a] -> IO [a] evaluateList xs = do     evaluate $ length xs-    return xs+    pure xs
− src/HSE/All.hs 
@@ -1,331 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE PackageImports #-}--module HSE.All(-    module X,-    CppFlags(..), ParseFlags(..), defaultParseFlags,-    parseFlagsAddFixities, parseFlagsSetLanguage,-    ParseError(..), ModuleEx(..),-    parseModuleEx,-    freeVars, vars, varss, pvars-    ) where--import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))-import qualified Language.Haskell.Exts.Util as X-import HSE.Util as X-import HSE.Reduce 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-import Data.Maybe-import Timing-import Language.Preprocessor.Cpphs-import Data.Either-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Set as Set-import System.IO.Extra-import Data.Functor-import Prelude--import GHC.Util-import qualified "ghc-lib-parser" HsSyn-import qualified "ghc-lib-parser" FastString-import qualified "ghc-lib-parser" SrcLoc as GHC-import qualified "ghc-lib-parser" ErrUtils-import qualified "ghc-lib-parser" Outputable-import qualified "ghc-lib-parser" GHC.LanguageExtensions.Type as GHC--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.-    | CppSimple -- ^ Lines prefixed with @#@ are stripped.-    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.---- | 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).-    }--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 = defaultExtensions}--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}}---- | 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--parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags-parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags 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 (Cpphs o) file x = dropLine <$> runCpphs o file x-    where-        -- LINE pragmas always inserted when locations=True-        dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b-        dropLine x = x-------------------------------------------------------------------------- PARSING---- | A parse error.-data ParseError = ParseError-    { parseErrorLocation :: SrcLoc -- ^ 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 {-    -- Combined 'hs-src-ext' and 'ghc-lib-parser' parse trees.-    pm_hsext  :: (Module SrcSpanInfo, [Comment]) -- hs-src-ext result-  , pm_ghclib :: Located (HsSyn.HsModule HsSyn.GhcPs) -- ghc-lib-parser result-}---- | 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-                       -> String-                       -> (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---- | Produce a pair of lists from a 'ParseFlags' value representing--- language extensions to explicitly enable/disable.-ghcExtensionsFromParseFlags :: ParseFlags-                             -> ([GHC.Extension], [GHC.Extension])-ghcExtensionsFromParseFlags ParseFlags {hseFlags=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---- | 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.-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-            Nothing | file == "-" -> getContentsUTF8-                    | otherwise -> readFileUTF8' file-        str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130-        ppstr <- runCpp (cppFlags flags) file str-        let enableDisableExts = ghcExtensionsFromParseFlags flags-        dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr-        case dynFlags of-          Right ghcFlags ->-            case (parseFileContentsWithComments (mkMode flags file) ppstr, parseFileGhcLib file ppstr ghcFlags) of-                (ParseOk (x, cs), POk _ a) ->-                    return $ Right (ModuleEx (applyFixity fixity x, cs) a)-                -- Parse error if GHC parsing fails (see-                -- https://github.com/ndmitchell/hlint/issues/645).-                (ParseOk _, PFailed _ loc err) ->-                    ghcFailOpParseModuleEx ppstr file str (loc, err)-                (ParseFailed sl msg, pfailed) ->-                    failOpParseModuleEx ppstr flags file str sl msg $ fromPFailed pfailed-          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))--    where-        fromPFailed (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 /= ""]
− src/HSE/Match.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}--module HSE.Match(-    View(..), Named(..),-    (~=), isSym,-    App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_), PApp_(PApp_)-    ) 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---- \_ -> body-data LamConst1 = NoLamConst1 | LamConst1 Exp_ deriving Show--instance View Exp_ LamConst1 where-    view (fromParen -> Lambda _ [PWildCard _] x) = LamConst1 x-    view _ = NoLamConst1--data PApp_ = NoPApp_ | PApp_ String [Pat_]--instance View Pat_ PApp_ where-    view (fromPParen -> PApp _ x xs) = PApp_ (fromNamed x) xs-    view (fromPParen -> PInfixApp _ lhs op rhs) = PApp_ (fromNamed op) [lhs, rhs]-    view _ = NoPApp_--data PVar_ = NoPVar_ | PVar_ String--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"
− src/HSE/Reduce.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE ViewPatterns #-}---- Evaluate/reduce a HSE Exp as much as possible-module HSE.Reduce(reduce) where--import HSE.Match-import HSE.Util-import HSE.Type-import Language.Haskell.Exts.Util---reduce :: Exp_ -> Exp_-reduce = fromParen . transform reduce1---reduce1 :: Exp_ -> Exp_-reduce1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n)-    where n = fromIntegral $ length xs-reduce1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n)-    where n = fromIntegral $ length xs-reduce1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y-reduce1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _)))-    | op ~= ">=" = toNamed $ show $ x >= y-reduce1 (view -> App2 op x y)-    | op ~= "&&" && x ~= "True"  = y-    | op ~= "&&" && x ~= "False" = x-reduce1 (Paren _ x) | isAtom x = x-reduce1 x = x
− src/HSE/Scope.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving #-}--module HSE.Scope(-    Scope, scopeCreate, scopeImports,-    scopeMatch, scopeMove-    ) 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------ | Given a two names in scopes, could they possibly refer to the same thing.---   This property is reflexive.-scopeMatch :: (Scope, QName S) -> (Scope, QName S) -> Bool-scopeMatch (a, x@Special{}) (b, y@Special{}) = x =~= y-scopeMatch (a, x) (b, y) | isSpecial x || isSpecial y = False-scopeMatch (a, x) (b, y) = unqual x =~= unqual y && not (null $ possModules a x `intersect` 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, it picks a plausible candidate.-scopeMove :: (Scope, QName S) -> Scope -> QName S-scopeMove (a, x@(fromQual -> Just name)) (Scope b)-    | null imps = head $ real ++ [x]-    | any (not . importQualified) imps = unqual x-    | otherwise = Qual an (head $ mapMaybe importAs imps ++ map importModule imps) name-    where-        real = [Qual an (ModuleName an m) name | m <- possModules a x]-        imps = [i | r <- real, i <- b, possImport i r]-scopeMove (_, x) _ = x----- which modules could a name possibly lie in--- if it's qualified but not matching any import, assume the user--- just lacks an import-possModules :: Scope -> QName S -> [String]-possModules (Scope is) x = f x-    where-        res = [fromModuleName $ importModule i | i <- is, possImport i x]--        f Special{} = [""]-        f x@(Qual _ mod _) = [fromModuleName mod | null res] ++ res-        f _ = res---possImport :: ImportDecl S -> QName S -> Bool-possImport i Special{} = False-possImport i (Qual _ mod x) = fromModuleName mod `elem` map fromModuleName ms && possImport i{importQualified=False} (UnQual an x)-    where ms = importModule i : maybeToList (importAs i)-possImport i (UnQual _ x) = not (importQualified i) && maybe True f (importSpecs i)-    where-        f (ImportSpecList _ hide xs) = if hide then Just True `notElem` ms else Nothing `elem` ms || Just True `elem` ms-            where ms = map g xs--        g :: ImportSpec S -> Maybe Bool -- does this import cover the name x-        g (IVar _ y) = Just $ x =~= y-        g (IAbs _ _ y) = Just $ x =~= y-        g (IThingAll _ y) = if x =~= y then Just True else Nothing-        g (IThingWith _ y ys) = Just $ x `elem_` (y : map fromCName ys)--        fromCName :: CName S -> Name S-        fromCName (VarName _ x) = x-        fromCName (ConName _ x) = x
− src/HSE/Type.hs 
@@ -1,19 +0,0 @@--module HSE.Type(-    S,-    Module_, Decl_, Exp_, Pat_, Type_,-    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-type Type_ = Type S
− src/HSE/Unify.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module HSE.Unify(-    Subst, fromSubst,-    validSubst, substitute,-    unifyExp,-    ) where--import Control.Applicative-import Data.List.Extra-import Data.Maybe-import Data.Data-import Data.Semigroup-import Config.Type-import Hint.Type-import Control.Monad-import Data.Tuple.Extra-import Util-import Prelude--------------------------------------------------------------------------- SUBSTITUTION DATA TYPE---- | 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)---- | 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--instance Pretty a => Show (Subst a) where-    show (Subst xs) = unlines [a ++ " = " ++ prettyPrint b | (a,b) <- xs]----- check the unification is valid and simplify it-validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)-validSubst eq = fmap Subst . mapM f . groupSort . fromSubst-    where f (x,y:ys) | all (eq y) ys = Just (x,y)-          f _ = Nothing----- | Perform a substitution-substitute :: Subst Exp_ -> Exp_ -> Exp_-substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ-    where-        exp (Var _ (fromNamed -> x)) = lookup x bind-        exp (InfixApp s lhs (fromNamed -> x) rhs) =-            (\op -> InfixApp s lhs op rhs) <$> lookupOp x-        exp (LeftSection s exp (fromNamed -> x)) =-            LeftSection s exp <$> lookupOp x-        exp (RightSection s (fromNamed -> x) exp) =-            (\op -> RightSection s op exp) <$> lookupOp x-        exp _ = Nothing--        -- Substition for operator must be an operator name-        lookupOp x = toNamed . fromNamed <$> lookup x bind--        pat (PVar _ (fromNamed -> x)) | Just y <- lookup x bind = toNamed $ fromNamed y-        pat x = x :: Pat_--        typ (TyVar _ (fromNamed -> x)) | Just (TypeApp _ y) <- lookup x bind = y-        typ x = x :: Type_-------------------------------------------------------------------------- UNIFICATION--type NameMatch = QName S -> QName S -> Bool--nmOp :: NameMatch -> QOp S -> QOp S -> Bool-nmOp nm (QVarOp _ x) (QVarOp _ y) = nm x y-nmOp nm (QConOp _ x) (QConOp _ y) = nm x y-nmOp nm  _ _ = False----- | Unification, obeys the property that if @unify a b = s@, then @substitute s a = b@.-unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst Exp_)-unify nm root x y-    | Just (x,y) <- cast (x,y) = unifyExp nm root x y-    | Just (x,y) <- cast (x,y) = unifyPat nm x y-    | Just (x,y) <- cast (x,y) = unifyType nm x y-    | Just (x :: S) <- cast x = Just mempty-    | otherwise = unifyDef nm x y---unifyDef :: Data a => NameMatch -> a -> a -> Maybe (Subst Exp_)-unifyDef nm x y = fmap mconcat . sequence =<< gzip (unify nm False) x y----- App/InfixApp are analysed specially for performance reasons--- 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 readRule (Bug #570)-unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe (Subst Exp_)---- brackets are not added when expanding $ in the users code, so tolerate them--- in the match even if they aren't in the users code-unifyExp nm root x y | not root, isParen x, not $ isParen y = unifyExp nm root (fromParen x) y--unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just $ Subst [(v,y)]-unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just mempty---- Match wildcard operators-unifyExp nm root (InfixApp _ lhs1 (fromNamed -> v) rhs1) (InfixApp _ lhs2 (fromNamed -> op2) rhs2)-    | isUnifyVar v =-        (Subst [(v, toNamed op2)] <>) <$>-        liftM2 (<>) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)-unifyExp nm root (LeftSection _ exp1 (fromNamed -> v)) (LeftSection _ exp2 (fromNamed -> op2))-    | isUnifyVar v =-        (Subst [(v, toNamed op2)] <>) <$> unifyExp nm False exp1 exp2-unifyExp nm root (RightSection _ (fromNamed -> v) exp1) (RightSection _ (fromNamed -> op2) exp2)-    | isUnifyVar v =-        (Subst [(v, toNamed op2)] <>) <$> unifyExp nm False exp1 exp2---- Options: match directly, and expand through .-unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) =-    liftM2 (<>) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus`-    (do guard $ not root-            -- don't expand . if at the root, otherwise you can get duplicate matches-            -- because the matching engine auto-generates hints in dot-form-        InfixApp _ y11 dot y12 <- return $ fromParen y1-        guard $ isDot dot-        unifyExp nm root x (App an y11 (App an y12 y2)))---- Options: match directly, then expand through $, then desugar infix-unifyExp nm root x (InfixApp _ lhs2 op2 rhs2)-    | InfixApp _ lhs1 op1 rhs1 <- x = guard (nmOp nm op1 op2) >> liftM2 (<>) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2)-    | isDol op2 = unifyExp nm root x $ App an lhs2 rhs2-    | otherwise = unifyExp nm root x $ App an (App an (opExp op2) lhs2) rhs2--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 Var{} = False-        isOther App{} = False-        isOther InfixApp{} = False-        isOther _ = True--unifyExp nm root _ _ = Nothing---unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe (Subst Exp_)-unifyPat nm (PVar _ x) (PVar _ y) = Just $ Subst [(fromNamed x, toNamed $ fromNamed y)]-unifyPat nm (PVar _ x) PWildCard{} = Just $ Subst [(fromNamed x, toNamed $ "_" ++ fromNamed x)]-unifyPat nm x y = unifyDef nm x y---unifyType :: NameMatch -> Type_ -> Type_ -> Maybe (Subst Exp_)-unifyType nm (TyVar a x) y = Just $ Subst [(fromNamed x, TypeApp a y)]-unifyType nm x y = unifyDef nm x y
− src/HSE/Util.hs 
@@ -1,428 +0,0 @@-{-# LANGUAGE FlexibleContexts, ViewPatterns, 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--isKindHash :: Type_ -> Bool-isKindHash (TyParen _ x) = isKindHash x-isKindHash (TyApp _ x _) = isKindHash x-isKindHash (TyCon _ (fromQual -> Just (Ident _ s))) = "#" `isSuffixOf`  s-isKindHash (TyTuple _ Unboxed _) = True-isKindHash TyUnboxedSum{} = True-isKindHash _ = False---getEquations :: Decl s -> [Decl s]-getEquations (FunBind s xs) = map (FunBind s . (:[])) xs-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-extensionImplications :: [(Extension, [Extension])]-extensionImplications = map (first EnableExtension) $-    (RebindableSyntax, [DisableExtension ImplicitPrelude]) :-    map (\(k, vs) -> (k, map EnableExtension vs))-    [ (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])-    ]
src/Hint/All.hs view
@@ -1,6 +1,6 @@  module Hint.All(-    Hint(..), HintBuiltin(..), DeclHint, ModuHint,+    Hint(..), ModuHint,     resolveHints, hintRules, builtinHints     ) where @@ -19,7 +19,9 @@ import Hint.Monad import Hint.Lambda import Hint.Bracket+import Hint.Fixities import Hint.Naming+import Hint.Negation import Hint.Pattern import Hint.Import import Hint.Export@@ -31,51 +33,58 @@ import Hint.Unsafe import Hint.NewType import Hint.Smell+import Hint.NumLiteral  -- | A list of the builtin hints wired into HLint. --   This list is likely to grow over time. data HintBuiltin =-    HintList | HintListRec | HintMonad | HintLambda |+    HintList | HintListRec | HintMonad | HintLambda | HintFixities | HintNegation |     HintBracket | HintNaming | HintPattern | HintImport | HintExport |     HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |-    HintComment | HintNewType | HintSmell+    HintComment | HintNewType | HintSmell | HintNumLiteral     deriving (Show,Eq,Ord,Bounded,Enum) +-- See https://github.com/ndmitchell/hlint/issues/1150 - Duplicate is too slow+-- and doesn't provide much value anyway.+issue1150 = True  builtin :: HintBuiltin -> Hint builtin x = case x of-    HintList       -> decl listHint-    HintListRec    -> decl listRecHint-    HintMonad      -> decl monadHint     HintLambda     -> decl lambdaHint-    HintBracket    -> decl bracketHint-    HintNaming     -> decl namingHint-    HintPattern    -> decl patternHint     HintImport     -> modu importHint     HintExport     -> modu exportHint+    HintComment    -> modu commentHint     HintPragma     -> modu pragmaHint-    HintExtensions -> modu extensionsHint-    HintUnsafe     -> decl unsafeHint-    HintDuplicate  -> mods duplicateHint-    HintComment    -> comm commentHint-    HintNewType    -> decl newtypeHint+    HintDuplicate  -> if issue1150 then mempty else mods duplicateHint     HintRestrict   -> mempty{hintModule=restrictHint}+    HintList       -> decl listHint+    HintNewType    -> decl newtypeHint+    HintUnsafe     -> decl unsafeHint+    HintListRec    -> decl listRecHint+    HintNaming     -> decl namingHint+    HintBracket    -> decl bracketHint+    HintFixities   -> mempty{hintDecl=fixitiesHint}+    HintNegation   -> decl negationParensHint     HintSmell      -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}+    HintPattern    -> decl patternHint+    HintMonad      -> decl monadHint+    HintExtensions -> modu extensionsHint+    HintNumLiteral -> decl numLiteralHint     where         wrap = timed "Hint" (drop 4 $ show x) . forceList         decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}         modu f = mempty{hintModule=const $ \a b -> wrap $ f a b}         mods f = mempty{hintModules=const $ \a -> wrap $ f a}-        comm f = mempty{hintComment=const $ \a -> wrap $ f a}  -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)]-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)-    where (lefts,rights) = partitionEithers xs+resolveHints xs =+  mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nubOrd lefts)+  where (lefts,rights) = partitionEithers xs  -- | Transform a list of 'HintRule' into a 'Hint'. hintRules :: [HintRule] -> Hint
src/Hint/Bracket.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} {--Raise an error if you are bracketing an atom, or are enclosed be a list bracket +Raise an error if you are bracketing an atom, or are enclosed by a+list bracket.+ <TEST> -- expression bracket reduction yes = (f x) x -- @Suggestion f x x@@ -24,14 +29,30 @@ main = do f; (print x) -- @Suggestion do f print x yes = f (x) y -- @Warning x no = f (+x) y-no = f ($x) y-no = ($x)-yes = (($x))-no = ($1)-yes = (($1)) -- @Warning ($1)+no = f ($ x) y+no = ($ x)+yes = (($ x))  -- @Warning ($ x)+no = ($ 1)+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}+issue970 = (f x +) (g x) -- f x + (g x)+issue969 = (Just \x -> x || x) *> Just True+issue1179 = do(this is a test) -- do this is a test+issue1212 = $(Git.hash) +-- no record dot syntax+referenceDesignator = ReferenceDesignator (p.placementReferenceDesignator)++-- record dot syntax+{-# LANGUAGE OverloadedRecordDot #-} \+referenceDesignator = ReferenceDesignator (p.placementReferenceDesignator) -- p.placementReferenceDesignator @NoRefactor: refactor requires GHC >= 9.2.1+ -- type bracket reduction foo :: (Int -> Int) -> Int foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a@@ -42,7 +63,6 @@ foo (x:xs) = 1 foo (True) = 1 -- @Warning True foo ((True)) = 1 -- @Warning True-foo (A{}) = True -- A{} f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing  -- dollar reduction tests@@ -52,6 +72,7 @@ yes = operator foo $ operator -- operator foo operator no = operator foo $ operator bar yes = return $ Record{a=b}+no = f $ [1,2..5] -- f [1,2..5]  -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e@@ -79,102 +100,203 @@ special = foo $ f{x=1} special = foo $ Rec{x=1} special = foo (f{x=1})+loadCradleOnlyonce = skipManyTill anyMessage (message @PublishDiagnosticsNotification)+-- These used to require a bracket+$(pure [])+$(x)+-- People aren't a fan of the record constructors being secretly atomic+function (Ctor (Rec { field })) = Ctor (Rec {field = 1})++-- type splices are a bit special+no = f @($x)++-- template haskell is harder+issue1292 = [e| handleForeignCatch $ \ $(varP pylonExPtrVarName) -> $(quoteExp C.block modifiedStr) |]++-- no warnings for single-argument constraint contexts+foo :: (A) => ()+bar :: (A a) => ()+foo' :: ((A) => ()) -> ()+bar' :: ((A a) => ()) -> ()+data Dict c where Dict :: (c) => Dict c+data Dict' c a where Dict' :: (c a) => Dict' c a++-- issue1501: Redundant bracket hint resulted in a parse error+x = f $ \(Proxy @a) -> True </TEST> -}   module Hint.Bracket(bracketHint) where -import Hint.Type+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSSA) import Data.Data+import Data.List.Extra+import Data.Generics.Uniplate.DataOnly import Refact.Types +import GHC.Hs+import GHC.Utils.Outputable+import GHC.Types.SrcLoc+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat  bracketHint :: DeclHint bracketHint _ _ x =-    concatMap (\x -> bracket isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [Exp_]) ++-    concatMap (bracket (const False) False) (childrenBi x :: [Type_]) ++-    concatMap (bracket (const False) False) (childrenBi x :: [Pat_]) ++-    concatMap fieldDecl (childrenBi x)-    where-        -- Brackets at the roots of annotations are fine, so we strip them-        annotations :: Annotation S -> Annotation S-        annotations = descendBi $ \x -> case (x :: Exp_) of-            Paren _ x -> x-            x -> x+  concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) +++  concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi (preprocess x) :: [LHsType GhcPs]) +++  concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LPat GhcPs]) +++  concatMap fieldDecl (childrenBi x)+   where+     preprocess = transformBi removeSingleAtomConstrCtxs+       where+         removeSingleAtomConstrCtxs :: LHsContext GhcPs -> LHsContext GhcPs+         removeSingleAtomConstrCtxs = fmap $ \case+           [ty] | isAtom ty -> []+           tys -> tys -isPartialAtom :: Exp_ -> Bool-isPartialAtom (SpliceExp _ IdSplice{}) = True -- might be $x, which was really $ x, but TH enabled misparsed it-isPartialAtom x = isRecConstr x || isRecUpdate x+     -- Brackets the roots of annotations are fine, so we strip them.+     annotations :: AnnDecl GhcPs -> AnnDecl GhcPs+     annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of+       L _ (HsPar _ x) -> x+       x -> x --- Dirty, should add to Brackets type class I think-tyConToRtype :: String -> RType-tyConToRtype "Exp" = Expr-tyConToRtype "Type" = Type-tyConToRtype "Pat"  = Pattern-tyConToRtype _      = Expr+     -- Brackets at the root of splices used to be required, but now they aren't+     splices :: HsDecl GhcPs -> HsDecl GhcPs+     splices (SpliceD a x) = SpliceD a $ flip descendBi x $ \x -> case (x :: LHsExpr GhcPs) of+       L _ (HsPar _ x) -> x+       x -> x+     splices x = x -findType :: (Data a) => a -> RType-findType = tyConToRtype . dataTypeName . dataTypeOf+-- If we find ourselves in the context of a section and we want to+-- issue a warning that a child therein has unnecessary brackets,+-- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found :+-- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the+-- latter (in contrast to the HSE pretty printer). This patches things+-- up.+prettyExpr :: LHsExpr GhcPs -> String+prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs)+prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (nlHsPar s :: LHsExpr GhcPs)+prettyExpr x = unsafePrettyPrint x --- Just if at least one paren was removed--- Nothing if zero parens were removed-remParens :: Brackets a => a -> Maybe a-remParens = fmap go . remParen+-- 'Just _' if at least one set of parens were removed. 'Nothing' if+-- zero parens were removed.+remParens' :: Brackets (LocatedA a) => LocatedA a -> Maybe (LocatedA a)+remParens' = fmap go . remParen   where     go e = maybe e go (remParen e) -bracket :: forall a . (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => (a S -> Bool) -> Bool -> a S -> [Idea]-bracket isPartialAtom root = f Nothing-    where-        msg = "Redundant bracket"+-- note(sf, 2022-06-02): i've completely bluffed my way through this.+-- see+-- https://gitlab.haskell.org/ghc/ghc/-/commit/7975202ba9010c581918413808ee06fbab9ac85f+-- for where splice expressions were refactored.+isPartialAtom :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool+-- Might be '$x', which was really '$ x', but TH enabled misparsed it.+isPartialAtom _ (L _ (HsUntypedSplice _ HsUntypedSpliceExpr{})) = True+-- Might be '$(x)' where the brackets are required in GHC 8.10 and below+isPartialAtom (Just (L _ HsUntypedSplice{})) _ = True+isPartialAtom _ x = isRecConstr x || isRecUpdate x -        -- f (Maybe (index, parent, gen)) child-        f :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]-        f Just{} o@(remParens -> Just x) | isAtom x, not $ isPartialAtom x = bracketError msg o x : g x-        f Nothing o@(remParens -> Just x) | root || isAtom x, not $ isPartialAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x-        f (Just (i,o,gen)) v@(remParens -> Just x) | not $ needBracket i o x, not $ isPartialAtom x =-          suggest msg o (gen x) [r] : g x-          where-            typ = findType v-            r = Replace typ (toSS v) [("x", toSS x)] "x"-        f _ x = g x+bracket :: forall a . (Data a, Outputable a, Brackets (LocatedA a)) => (LocatedA a -> String) -> (Maybe (LocatedA a) -> LocatedA a -> Bool) -> Bool -> LocatedA a -> [Idea]+bracket pretty isPartialAtom root = f Nothing+  where+    msg = "Redundant bracket"+    -- 'f' is a (generic) function over types in 'Brackets+    -- (expressions, patterns and types). Arguments are, 'f (Maybe+    -- (index, parent, gen)) child'.+    f :: (Data a, Outputable a, Brackets (LocatedA a)) => Maybe (Int, LocatedA a , LocatedA a -> LocatedA a) -> LocatedA a -> [Idea]+    -- No context. Removing parentheses from 'x' succeeds?+    f Nothing o@(remParens' -> Just x)+      -- If at the root, or 'x' is an atom, 'x' parens are redundant.+      | root || isAtom x+      , not $ isPartialAtom Nothing x =+          (if isAtom x then bracketError else bracketWarning) msg o x : g x+    -- In some context, removing parentheses from 'x' succeeds and 'x'+    -- is atomic?+    f (Just (_, p, _)) o@(remParens' -> Just x)+      | isAtom x+      , not $ isPartialAtom (Just p) x =+          bracketError msg o x : g x+    -- In some context, removing parentheses from 'x' succeeds. Does+    -- 'x' actually need bracketing in this context?+    f (Just (i, o, gen)) v@(remParens' -> Just x)+      | not $ needBracket i o x+      , not $ isPartialAtom (Just o) x+      , not $ any isSplicePat $ universeBi o -- over-appoximate ,see #1292+      = rawIdea Suggestion msg (getLocA v) (pretty o) (Just (pretty (gen x))) [] [r] : g x+      where+        typ = findType v+        r = Replace typ (toSSA v) [("x", toSSA x)] "x"+    -- Regardless of the context, there are no parentheses to remove+    -- from 'x'.+    f _ x = g x -        g :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]-        g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o]+    g :: (Data a, Outputable a, Brackets (LocatedA a)) => LocatedA 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)) <- zipFrom 0 $ holes o]  bracketWarning msg o x =-  suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+  suggest msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"]++bracketError :: (Outputable a, Outputable b, Brackets (LocatedA b)) => String -> LocatedA a -> LocatedA b -> Idea bracketError msg o x =-  warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+  warn msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA x)] "x"] +fieldDecl ::  LConDeclField GhcPs -> [Idea]+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" (locA l)+    (showSDocUnsafe $ ppr_fld o) -- Note this custom printer!+    (Just (showSDocUnsafe $ ppr_fld r))+    []+    [Replace Type (toSSA v) [("x", toSSA c)] "x"]]+   where+     -- If we call 'unsafePrettyPrint' on a field decl, we won't like+     -- the output (e.g. "[foo, bar] :: T"). Here we use a custom+     -- printer to work around (snarfed from Hs.Types.pprConDeclFields)+     ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })+       = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)+     ppr_fld (L _ (XConDeclField x)) = ppr x -fieldDecl :: FieldDecl S -> [Idea]-fieldDecl o@(FieldDecl a b v@(TyParen _ c))-    = [suggest "Redundant bracket" o (FieldDecl a b c)  [Replace Type (toSS v) [("x", toSS c)] "x"]]+     ppr_names [n] = ppr n+     ppr_names ns = sep (punctuate comma (map ppr ns)) fieldDecl _ = [] --dollar :: Exp_ -> [Idea]+-- This function relies heavily on fixities having been applied to the+-- raw parse tree.+dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe-    where-        f x = [suggest "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$"-              ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b, not $ isPartialAtom b-              ,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]-              ++-              [suggest "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x-              ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2-              ,not $ a1 ~= "select" -- special case for esqueleto, see #224-              , let y = App an a1 (Paren an a2)-              , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]-              ++-              -- special case of (v1 . v2) <$> v3-              [suggest "Redundant bracket" x y []-              | InfixApp _ (Paren _ o1@(InfixApp _ v1 (isDot -> True) v2)) o2 v3 <- [x], opExp o2 ~= "<$>"-              , let y = InfixApp an o1 o2 v3]-+  where+    f x = [ (suggest "Redundant $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d+            , let y = noLocA (HsApp noExtField a b) :: LHsExpr GhcPs+            , not $ needBracket 0 y a+            , not $ needBracket 1 y b+            , not $ isPartialAtom (Just x) b+            , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"]+          +++          [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r]+            |(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 = noLocA $ HsApp noExtField a1 (nlHsPar a2)+            , let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)" ]+          ++  -- Special case of (v1 . v2) <$> v3+          [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]){ideaSpan = locA locPar}+          | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>"+          , let y = noLocA (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs+          , let r = Replace Expr (toRefactSrcSpan (locA locPar)) [("a", toRefactSrcSpan (locA locNoPar))] "a"]+          +++          [ suggest "Redundant section" (reLoc x) (reLoc y) [r]+          | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x]+          -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)+          , let y = noLocA $ OpApp noExtField a b c :: LHsExpr GhcPs+          , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"] --- return both sides, and a way to put them together again-splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)]-splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)]+splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]+splitInfix (L l (OpApp _ lhs op rhs)) =+  [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)] splitInfix _ = []
src/Hint/Comment.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-}  {- <TEST>@@ -18,21 +19,35 @@ import Data.Char import Data.List.Extra import Refact.Types(Refactoring(ModifyComment))-+import GHC.Types.SrcLoc+import GHC.Parser.Annotation+import GHC.Util+import GHC.Data.Strict qualified -pragmas = words $+directives :: [String]+directives = words $     "LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++     "CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE"  -commentHint :: Comment -> [Idea]-commentHint c@(Comment True span s)-    | "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" c $ '#':s]-    | name `elem` pragmas = [grab "Use pragma syntax" c $ "# " ++ trim s ++ " #"]-        where name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s-commentHint _ = []+commentHint :: ModuHint+commentHint _ m = concatMap chk (ghcComments m)+    where+        chk :: LEpaComment -> [Idea]+        chk comm+          | isMultiline, "#" `isSuffixOf` s && not ("#" `isPrefixOf` s) = [grab "Fix pragma markup" comm $ '#':s]+          | isMultiline, name `elem` directives = [grab "Use pragma syntax" comm $ "# " ++ trim s ++ " #"]+               where+                 isMultiline = isCommentMultiline comm+                 s = commentText comm+                 name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s+        chk _ = [] -grab :: String -> Comment -> String -> Idea-grab msg (Comment typ pos s1) s2 = rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact-    where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s-          refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]+        grab :: String -> LEpaComment -> String -> Idea+        grab msg o@(L pos _) s2 =+          let s1 = commentText o+              loc = RealSrcSpan (epaLocationRealSrcSpan pos) GHC.Data.Strict.Nothing+          in+          rawIdea Suggestion msg loc (f s1) (Just $ f s2) [] (refact loc)+            where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s+                  refact loc = [ModifyComment (toRefactSrcSpan loc) (f s2)]
src/Hint/Duplicate.hs view
@@ -1,52 +1,78 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}  {- Find bindings within a let, and lists of statements If you have n the same, error out -<TEST>+<TEST_DISABLED_1150>+foo = a where {a = 1; b = 2; c = 3} \+bar = a where {a = 1; b = 2; c = 3} -- ??? 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; 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 ???-</TEST>+</TEST_DISABLED_1150> -}   module Hint.Duplicate(duplicateHint) where -import Hint.Type+import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN,Severity(Suggestion,Warning))+import Data.Data+import Data.Generics.Uniplate.DataOnly import Data.Default+import Data.Maybe import Data.Tuple.Extra import Data.List hiding (find)-import qualified Data.Map as Map+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as Map +import GHC.Types.SrcLoc+import GHC.Hs+import GHC.Utils.Outputable+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable  duplicateHint :: CrossHint duplicateHint ms =-    dupes [(m,d,y) | (m,d,x) <- ds, Do _ y :: Exp S <- universeBi x] ++-    dupes [(m,d,y) | (m,d,x) <- ds, BDecls _ y :: Binds S <- universeBi x]-    where ds = [(moduleName m, fromNamed d, d) | m <- map snd ms, d <- moduleDecls m]-+   -- Do expressions.+   dupes [ (m, d, y)+         | (m, d, x) <- ds+         , HsDo _ _ (L _ y) :: HsExpr GhcPs <- universeBi x+         ] +++  -- Bindings in a 'let' expression or a 'where' clause.+   dupes [ (m, d, y)+         | (m, d, x) <- ds+         , HsValBinds _ (ValBinds _ b _ ) :: HsLocalBinds GhcPs <- universeBi x+         , let y = b+         ]+    where+      ds = [(modName m, fromMaybe "" (declName d), unLoc d)+           | ModuleEx m <- map snd ms+           , d <- hsmodDecls (unLoc m)] -dupes :: (Pretty (f SrcSpan), Annotated f, Ord (f ())) => [(String, String, [f S])] -> [Idea]+dupes :: (Outputable e, Data e) => [(String, String, [LocatedA e])] -> [Idea] dupes ys =     [(rawIdeaN-        (if length xs >= 5 then Warning else Suggestion)+        (if length xs >= 5 then Hint.Type.Warning else Suggestion)         "Reduce duplication" p1-        (unlines $ map (prettyPrint . fmap (const p1)) xs)-        (Just $ "Combine with " ++ showSrcLoc (getPointLoc p2)) [])-      {ideaModule = [m1,m2], ideaDecl = [d1,d2]}-    | ((m1,d1,p1),(m2,d2,p2),xs) <- duplicateOrdered 3 $ map f ys]+        (unlines $ map unsafePrettyPrint xs)+        (Just $ "Combine with " ++ showSrcSpan p2)+        []+     ){ideaModule = [m1, m2], ideaDecl = [d1, d2]}+    | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys]     where-        f (m,d,xs) = [((m,d,srcInfoSpan $ ann x), dropAnn x) | x <- xs]-+      f (m, d, xs) =+        [((m, d, SrcSpanD (locA (getLoc x))), extendInstances (stripLocs x)) | x <- xs]  --------------------------------------------------------------------- -- DUPLICATE FINDING@@ -66,22 +92,28 @@ add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp     where f new = add pos vs --duplicateOrdered :: (Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])]+duplicateOrdered :: forall pos val.+  (Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])] duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs     where-        f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs+        f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]])+        f d xs = second overlaps $ mapAccumL (g pos) d $ onlyAtLeast threshold $ tails xs             where pos = Map.fromList $ zip (map fst xs) [0..] +        g :: Map.Map pos Int -> Dupe pos val -> NE.NonEmpty (pos, val) -> (Dupe pos val, [(pos, pos, [val])])         g pos d xs = (d2, res)             where                 res = [(p,pme,take mx vs) | i >= threshold                       ,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos                       ,mx >= threshold]-                vs = map snd xs+                vs = NE.toList $ snd <$> xs                 (p,i) = find vs d-                pme = fst $ head xs+                pme = fst $ NE.head xs                 d2 = add pme vs d++        onlyAtLeast n = mapMaybe $ \l -> case l of+           x:xs | length l >= n -> Just (x NE.:| xs)+           _ -> Nothing          overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs)         overlaps (x:xs) = x : overlaps xs
src/Hint/Export.hs view
@@ -9,18 +9,38 @@ module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where </TEST> -}+{-# LANGUAGE TypeFamilies #-}  module Hint.Export(exportHint) where -import Hint.Type+import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore,Note(..)) +import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader  exportHint :: ModuHint-exportHint _ (Module _ (Just o@(ModuleHead a name warning exports)) _ _ _)-    | Nothing <- exports =-        let o2 = ModuleHead a name warning $ Just $ ExportSpecList a [EModuleContents a name]-        in [(ignore "Use module export list" o o2 []){ideaNote = [Note "an explicit list is usually better"]}]-    | Just (ExportSpecList _ xs) <- exports, EModuleContents a name `elem_` xs =-        let o2 = ModuleHead a name warning $ Just $ ExportSpecList a $ EVar a ellipses : delete_ (EModuleContents a name) xs-        in [ignore "Use explicit module export list" o o2 []]+exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) )+  | Nothing <- exports =+      let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, noAnn) 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) | (L _ (IEModuleContents _ n)) <- mods]+  , exports' <- [x | x <- xs, not (matchesModName modName x)]+  , modName `elem` names =+      let dots = mkRdrUnqual (mkVarOcc " ... ")+          r = o{ hsmodExports = Just (noLocA (noLocA (IEVar Nothing (noLocA (IEName noExtField (noLocA dots))) Nothing) : exports') )}+      in+        [ignore "Use explicit module export list" (L s o) (noLoc r) []]+      where+          o = m{hsmodImports=[], hsmodDecls=[] }+          isMod (L _ (IEModuleContents _ _)) = True+          isMod _ = False++          matchesModName m (L _ (IEModuleContents _ (L _ n))) = moduleNameString n == m+          matchesModName _ _ = False+ exportHint _ _ = []
src/Hint/Extensions.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}  {-     Suggest removal of unnecessary extensions@@ -15,7 +16,9 @@ {-# LANGUAGE TemplateHaskell #-} \ $(deriveNewtypes typeInfo) {-# LANGUAGE TemplateHaskell #-} \-main = foo ''Bar+main = foo ''Bar --+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} \+f x = x + [e| x + 1 |] + [foo| x + 1 |] -- {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternGuards #-} \ test = case x of _ | y <- z -> w {-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \@@ -29,6 +32,37 @@ sort !f = undefined {-# LANGUAGE KindSignatures #-} \ data Set (cxt :: * -> *) a = Set [a]+{-# LANGUAGE BangPatterns #-} \+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 #-} \@@ -64,12 +98,25 @@ deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \ newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, TypeFamilies #-} \+data family Bar a; data instance Bar Foo = Foo deriving Generic {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ instance Class Int where {newtype MyIO a = MyIO a deriving NewClass} {-# LANGUAGE UnboxedTuples #-} \ f :: Int -> (# Int, Int #) {-# LANGUAGE UnboxedTuples #-} \ f :: x -> (x, x); f x = (x, x) --+{-# LANGUAGE UnboxedTuples #-} \+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 #-} \@@ -78,6 +125,8 @@ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int+{-# LANGUAGE TypeApplications #-} \+x :: Typeable b => TypeRep @Bool b {-# LANGUAGE LambdaCase #-} \ foo = id -- {-# LANGUAGE LambdaCase #-} \@@ -96,6 +145,18 @@ main = "test" {-# LANGUAGE OverloadedStrings #-} \ main = id --+{-# LANGUAGE OverloadedLists #-} \+main = []+{-# LANGUAGE OverloadedLists #-} \+main = [1]+{-# LANGUAGE OverloadedLists #-} \+main [1] = True+{-# LANGUAGE OverloadedLists #-} \+main = id --+{-# LANGUAGE OverloadedLabels #-} \+main = #foo+{-# LANGUAGE OverloadedLabels #-} \+main = id -- {-# LANGUAGE DeriveAnyClass #-} \ main = id -- {-# LANGUAGE DeriveAnyClass #-} \@@ -127,78 +188,197 @@ 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 NumericUnderscores #-} \+lessThanPi = (< 3.141_592_653_589_793)+{-# LANGUAGE NumericUnderscores #-} \+oneMillion = 0xf4__240+{-# LANGUAGE NumericUnderscores #-} \+avogadro = 6.022140857e+23 --+{-# LANGUAGE StaticPointers #-} \+static = 42 --+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Trustworthy, NamedFieldPuns #-} -- {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE NoStarIsType, ExplicitNamespaces #-} \+import GHC.TypeLits(KnownNat, type (+), type (*))+{-# LANGUAGE LambdaCase, MultiWayIf, NoRebindableSyntax #-} \+foo = \case True -> 3 -- {-# LANGUAGE LambdaCase, NoRebindableSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-} \+import Control.Monad qualified as CM+{-# LANGUAGE ImportQualifiedPost #-} \+import qualified Control.Monad as CM hiding (mapM) \+import Data.Foldable -- @NoRefactor: refactor only works when using GHC 8.10+{-# LANGUAGE StandaloneKindSignatures #-} \+type T :: (k -> Type) -> k -> Type \+data T m a = MkT (m a) (T Maybe (m a))+{-# LANGUAGE NoMonomorphismRestriction, NamedFieldPuns #-} \+main = 1 -- @Note Extension NamedFieldPuns is not used+{-# LANGUAGE FunctionalDependencies #-} \+class HasField x r a | x r -> a+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x.foo+{-# LANGUAGE OverloadedRecordDot #-} \+f x = x . foo -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE OverloadedRecordDot #-} \+f = (.foo)+{-# LANGUAGE OverloadedRecordDot #-} \+f = (. foo) -- @NoRefactor: refactor requires GHC >= 9.2.1+{-# LANGUAGE TemplateHaskellQuotes #-} \+foo = [|| x ||]+{-# LANGUAGE TemplateHaskell #-} \+foo = $bar+{-# LANGUAGE TemplateHaskell #-} \+foo = $$typedExpressionSplice+{-# LANGUAGE TypeData # -} \+type data Nat = Zero | Succ Nat  -- @NoRefactor: refactor requires GHC >= 9.6.1+{-# LANGUAGE TypeData #-} \+data T = MkT -- @NoRefactor: refactor requires GHC >= 9.6.1 </TEST> -}  + module Hint.Extensions(extensionsHint) where -import Hint.Type+import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments,firstDeclComments)+import Extension++import Data.Generics.Uniplate.DataOnly import Control.Monad.Extra import Data.Maybe import Data.List.Extra-import Data.Ratio import Data.Data import Refact.Types-import Data.Semigroup-import qualified Data.Set as Set-import qualified Data.Map as Map-import Prelude+import Data.Set qualified as Set+import Data.Map qualified as Map +import GHC.Data.FastString+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Hs+import GHC.Types.Basic+import GHC.Types.Name.Reader+import GHC.Types.ForeignCall+import GHC.Data.Strict qualified+import GHC.Types.PkgQual +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.Type+import Language.Haskell.GhclibParserEx.GHC.Hs.Decls+import Language.Haskell.GhclibParserEx.GHC.Hs.Binds+import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp+import Language.Haskell.GhclibParserEx.GHC.Driver.Session+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+ extensionsHint :: ModuHint extensionsHint _ x =-    [ rawIdea Warning "Unused LANGUAGE pragma"-        (srcInfoSpan sl)-        (prettyPrint o)+    [+        rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"+        (RealSrcSpan (epaLocationRealSrcSpan sl) GHC.Data.Strict.Nothing)+        (comment_ (mkLanguagePragmas sl exts))         (Just newPragma)-        ( [RequiresExtension $ prettyExtension gone | x <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++-            [ Note $ "Extension " ++ prettyExtension x ++ " is " ++ reason x-            | x <- explainedRemovals])-        [ModifyComment (toSS o) newPragma]-    | o@(LanguagePragma sl exts) <- modulePragmas x-    , let before = map (parseExtension . prettyPrint) exts-    , let after = filter (`Set.member` keep) before+        ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] +++            [ Note $ "Extension " ++ s ++ " is " ++ reason x+            | (s, Just x) <- explainedRemovals])+        [ModifyComment (toSSAnc (mkLanguagePragmas sl exts)) newPragma]+    | (L sl _,  exts) <-+      -- Comments appearing without an empty line before the first+      -- declaration in a module are now associated with the+      -- declaration not the module so to be safe, look also at+      -- `firstDeclComments x`+      -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+      languagePragmas $ pragmas (modComments x) ++ pragmas (firstDeclComments x)+    , let before = [(x, readExtension x) | x <- exts]+    , let after = filter (maybe True (`Set.member` keep) . snd) before     , before /= after     , let explainedRemovals-            | null after && not (any (`Map.member` implied) before) = []+            | null after && not (any (`Map.member` implied) $ mapMaybe snd before) = []             | otherwise = before \\ after-    , let newPragma = if null after then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) after+    , let newPragma =+            if null after then "" else comment_ (mkLanguagePragmas sl $ map fst after)     ]-    where-        usedTH = used TemplateHaskell x || used QuasiQuotes x-            -- if TH or QuasiQuotes is on, can use all other extensions programmatically--        -- all the extensions defined to be used-        extensions = Set.fromList [parseExtension $ fromNamed e | LanguagePragma _ exts <- modulePragmas x, e <- exts]--        -- those extensions we detect to be useful-        useful = if usedTH then extensions  else Set.filter (`usedExt` x) extensions--        -- those extensions which are useful, but implied by other useful extensions-        implied = Map.fromList-            [ (e, a)-            | e <- Set.toList useful-            , a:_ <- [filter (`Set.member` useful) $ extensionImpliedBy e]]--        -- those we should keep-        keep =  useful `Set.difference` Map.keysSet implied+  where+    usedTH :: Bool+    usedTH = used TemplateHaskell (ghcModule x)+               || used TemplateHaskellQuotes (ghcModule x)+               || used QuasiQuotes (ghcModule x)+      -- If TH or QuasiQuotes is on, can use all other extensions+      -- programmatically. -        -- (a,b) means a used to imply b, but has gone, so suggest enabling b-        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 `Set.notMember` useful-            , usedTH || usedExt a x-            ]+    -- All the extensions defined to be used.+    extensions :: Set.Set Extension+    extensions = Set.fromList $+      concatMap+      (mapMaybe readExtension . snd)+      (languagePragmas+        (pragmas (modComments x) ++ pragmas (firstDeclComments x)))+      -- Comments appearing without an empty line before the first+      -- declaration in a module are now associated with the+      -- declaration not the module so to be safe, look also at+      -- `firstDeclComments x`+      -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517). -        reason x =-            case Map.lookup x implied of-            Just a -> "implied by " ++ prettyExtension a-            Nothing -> "not used"+    -- Those extensions we detect to be useful.+    useful :: Set.Set Extension+    useful =+      if usedTH+        then Set.filter (\case TemplateHaskell -> usedExt TemplateHaskell (ghcModule x); _ -> True) extensions+        else Set.filter (`usedExt` ghcModule x) extensions+    -- Those extensions which are useful, but implied by other useful+    -- extensions.+    implied :: Map.Map Extension Extension+    implied = Map.fromList+        [ (e, a)+        | e <- Set.toList useful+        , 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 <- 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 " ++ show a+        Nothing -> "not used"  deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"] deriveGenerics = ["Data","Typeable","Generic","Generic1","Lift"]@@ -210,151 +390,203 @@     deriveGenerics -- Generics stuff can't newtype derive since it has the ctor in it  -- | Classes that can appear as stock, and can't appear as anyclass+deriveStock :: [String] deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory --usedExt :: Extension -> Module_ -> Bool-usedExt (EnableExtension x) = used x-usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac-usedExt (UnknownExtension "DeriveLift") = hasDerive ["Lift"]-usedExt (UnknownExtension "DeriveAnyClass") = not . null . derivesAnyclass . derives-usedExt _ = const True+usedExt :: Extension -> Located (HsModule GhcPs) -> Bool+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 :: Extension -> Located (HsModule GhcPs) -> Bool -used :: KnownExtension -> Module_ -> Bool used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp-used FunctionalDependencies = hasT (un :: FunDep S)-used ImplicitParams = hasT (un :: IPName S)-used TypeApplications = hasS isTypeApp+used FunctionalDependencies = hasT (un :: FunDep GhcPs)+used ImplicitParams = hasT (un :: HsIPName)++used TypeApplications = hasS isTypeApp ||^ hasS isKindTyApp+ used EmptyDataDecls = hasS f-    where f (DataDecl _ _ _ _ [] _) = True-          f (GDataDecl _ _ _ _ _ [] _) = True-          f _ = False+  where+    f :: HsDataDefn GhcPs -> Bool+    f (HsDataDefn _ _ _ _ (DataTypeCons _ []) _) = True+    f _ = False+used TypeData  = hasS f+  where+    f :: HsDataDefn GhcPs -> Bool+    f (HsDataDefn _ _ _ _ (DataTypeCons True _) _) = True+    f _ = False used EmptyCase = hasS f-    where f (Case _ _ []) = True-          f (LCase _ []) = True-          f (_ :: Exp_) = False-used KindSignatures = hasT (un :: Kind S)-used BangPatterns = hasS isPBangPat-used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) ||^ hasS f ||^ hasS isSpliceDecl-    where f VarQuote{} = True-          f TypQuote{} = True-          f _ = False-used ForeignFunctionInterface = hasT (un :: CallConv S)+  where+    f :: HsExpr GhcPs -> Bool+    f (HsCase _ _ (MG _ (L _ []))) = True+    f (HsLam _ LamCase (MG _ (L _ []))) = True+    f _ = False+used KindSignatures = hasT (un :: HsKind GhcPs)+used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch+used TemplateHaskell = hasS (not . isQuasiQuoteSplice) ||^ hasS isTypedSplice+used TemplateHaskellQuotes = hasS f+  where+    f :: HsExpr GhcPs -> Bool+    f HsTypedBracket{} = True+    f HsUntypedBracket{} = True+    f _ = False+used ForeignFunctionInterface = hasT (un :: CCallConv) used PatternGuards = hasS f-    where f (GuardedRhs _ xs _) = g xs-          g [] = False-          g [Qualifier{}] = False-          g _ = True-used StandaloneDeriving = hasS isDerivDecl-used PatternSignatures = hasS isPatTypeSig-used RecordWildCards = hasS isPFieldWildcard ||^ hasS isFieldWildcard-used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun-used NamedFieldPuns = hasS isPFieldPun ||^ hasS isFieldPun-used UnboxedTuples = has (not . isBoxed)-used PackageImports = hasS (isJust . importPkg)-used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote+  where+    f :: GRHS GhcPs (LHsExpr GhcPs) -> Bool+    f (GRHS _ xs _) = g xs+    g :: [GuardLStmt GhcPs] -> Bool+    g [] = False+    g [L _ BodyStmt{}] = False+    g _ = True+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 (L _ name) = isSymbolRdrName name++used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot+used NamedFieldPuns = 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)+      -- see https://github.com/ndmitchell/hlint/issues/833 for why we care+      isDeriving :: Maybe (LDerivStrategy GhcPs) -> Bool+      isDeriving _ = True+used PackageImports = hasS f+  where+      f :: ImportDecl GhcPs -> Bool+      f ImportDecl{ideclPkgQual=RawPkgQual _} = True+      f _ = False+used QuasiQuotes = hasS isQuasiQuoteExpr ||^ 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 GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives+used MultiWayIf = hasS isMultiIf+used NumericUnderscores = hasS f+  where+    f :: OverLitVal -> Bool+    f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` unpackFS t+    f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` unpackFS t+    f _ = False+ used LambdaCase = hasS isLCase used TupleSections = hasS isTupleSection used OverloadedStrings = hasS isString-used Arrows = hasS f-    where f Proc{} = True-          f LeftArrApp{} = True-          f RightArrApp{} = True-          f LeftArrHighApp{} = True-          f RightArrHighApp{} = True-          f _ = False-used TransformListComp = hasS f-    where f QualStmt{} = False-          f _ = True-used MagicHash = hasS f ||^ hasS isPrimLiteral-    where f (Ident _ s) = "#" `isSuffixOf` s-          f _ = False+used OverloadedLists = hasS isListExpr ||^ hasS isListPat+  where+    isListExpr :: HsExpr GhcPs -> Bool+    isListExpr (HsVar _ n) = rdrNameStr n == "[]"+    isListExpr ExplicitList{} = True+    isListExpr ArithSeq{} = True+    isListExpr _ = False --- for forwards compatibility, if things ever get added to the extension enumeration-used x = usedExt $ UnknownExtension $ show x+    isListPat :: Pat GhcPs -> Bool+    isListPat ListPat{} = True+    isListPat _ = False +used OverloadedLabels = hasS isOverLabel -hasDerive :: [String] -> Module_ -> Bool-hasDerive want = any (`elem` want) . derivesStock . derives+used Arrows = hasS isProc+used TransformListComp = hasS isTransStmt+used MagicHash = hasS f ||^ hasS isPrimLiteral+  where+    f :: RdrName -> Bool+    f s = "#" `isSuffixOf` occNameStr s+used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE+used ImportQualifiedPost = hasS (== QualifiedPost)+used StandaloneKindSignatures = hasT (un :: StandaloneKindSig GhcPs)+used OverloadedRecordDot = hasT (un :: DotFieldOcc GhcPs) +used _= const True +hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool+hasDerive want = any (`elem` want) . derivesStock' . derives+ -- Derivations can be implemented using any one of 3 strategies, so for each derivation -- add it to all the strategies that might plausibly implement it data Derives = Derives-    {derivesStock :: [String]+    {derivesStock' :: [String]     ,derivesAnyclass :: [String]-    ,derivesNewtype :: [String]+    ,derivesNewtype' :: [String]     } instance Semigroup Derives where     Derives x1 x2 x3 <> Derives y1 y2 y3 =-        Derives (x1++y1) (x2++y2) (x3++y3)+        Derives (x1 ++ y1) (x2 ++ y2) (x3 ++ y3) instance Monoid Derives where     mempty = Derives [] [] []     mappend = (<>) -addDerives :: Maybe (DataOrNew S) -> Maybe (DerivStrategy S) -> [String] -> Derives+addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives addDerives _ (Just s) xs = case s of-    DerivStock{} -> mempty{derivesStock = xs}-    DerivAnyclass{} -> mempty{derivesAnyclass = xs}-    DerivNewtype{} -> mempty{derivesNewtype = xs}-    DerivVia{} -> mempty+    StockStrategy {} -> mempty{derivesStock' = xs}+    AnyclassStrategy {} -> mempty{derivesAnyclass = xs}+    NewtypeStrategy {} -> mempty{derivesNewtype' = xs}+    ViaStrategy {} -> mempty addDerives nt _ xs = mempty-    {derivesStock = stock+    {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 ---- | What is derived on newtype, and on data type---   'deriving' declarations may be on either, so we approximate as both newtype and data-derives :: Module_ -> Derives-derives m = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)-    where-        idecl :: InstDecl S -> Derives-        idecl (InsData _ dn _ _ ds) = g dn ds-        idecl (InsGData _ dn _ _ _ ds) = g dn ds-        idecl _ = mempty--        decl :: Decl_ -> Derives-        decl (DataDecl _ dn _ _ _ ds) = g dn ds-        decl (GDataDecl _ dn _ _ _ _ ds) = g dn ds-        decl (DataInsDecl _ dn _ _ ds) = g dn ds-        decl (GDataInsDecl _ dn _ _ _ ds) = g dn ds-        decl (DerivDecl _ strategy _ hd) = addDerives Nothing strategy [ir hd]-        decl _ = mempty+derives :: Located (HsModule GhcPs) -> Derives+derives (L _ m) =  mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)+  where+    idecl :: DataFamInstDecl GhcPs -> Derives+    idecl (DataFamInstDecl FamEqn {feqn_rhs=HsDataDefn {dd_cons=data_defn_cons, dd_derivs=ds}}) = g (dataDefnConsNewOrData data_defn_cons) ds -        g dn ds = mconcat [addDerives (Just dn) strategy $ map ir rules | Deriving _ strategy rules <- ds]+    decl :: LHsDecl GhcPs -> Derives+    decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_cons=data_defn_cons, dd_derivs=ds}))) = g (dataDefnConsNewOrData data_defn_cons) ds -- Data declaration.+    decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration.+    decl _ = mempty -        ir (IRule _ _ _ x) = ih x-        ir (IParen _ x) = ir x+    g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives+    g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | (strategy, tys) <- stys]+      where+        stys =+          [(strategy, [ty]) | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds] +++          [(strategy, tys ) | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] -        ih (IHCon _ a) = prettyPrint $ unqual a-        ih (IHInfix _ _ a) = prettyPrint $ unqual a-        ih (IHParen _ a) = ih a-        ih (IHApp _ a _) = ih a+    derivedToStr :: LHsSigType GhcPs -> String+    derivedToStr (L _ (HsSig _ _ t)) = ih t+      where+        ih :: LHsType GhcPs -> String+        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.  un = undefined  hasT t x = not $ null (universeBi x `asTypeOf` [t])-hasT2 ~(t1,t2) = hasT t1 ||^ hasT t2 -hasS :: (Data x, Data (f S)) => (f S -> Bool) -> x -> Bool+hasS :: (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 :: Literal S -> Bool-isWholeFrac (Frac _ v _) = denominator v == 1-isWholeFrac _ = False
+ src/Hint/Fixities.hs view
@@ -0,0 +1,78 @@+{-++Raise a warning if you have redundant brackets in nested infix expressions.++<TEST>+yes = 1 + (2 * 3) -- @Ignore 1 + 2 * 3+yes = (2 * 3) + 1 -- @Ignore 2 * 3 + 1+no = (1 + 2) * 3+no = 3 * (1 + 2)+no = 1 + 2 * 3+no = 2 * 3 + 1+yes = (a >>= f) >>= g -- @Ignore a >>= f >>= g+no = (a >>= \x -> b) >>= g+</TEST>+-}++module Hint.Fixities(fixitiesHint) where++import Hint.Type(DeclHint,Idea(..),rawIdea,toSSA)+import Config.Type+import Control.Monad+import Data.List.Extra+import Data.Map+import Data.Generics.Uniplate.DataOnly+import Refact.Types++import GHC.Types.Fixity(compareFixity)+import Fixity+import GHC.Hs+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence++fixitiesHint :: [Setting] -> DeclHint+fixitiesHint settings _ _ x =+  concatMap (infixBracket fixities) (childrenBi x :: [LHsExpr GhcPs])+   where+     fixities = foldMap getFixity settings `mappend` fromList (toFixity <$> defaultFixities)+     getFixity (Infix x) = uncurry Data.Map.singleton (toFixity x)+     getFixity _ = mempty++infixBracket :: Map String Fixity -> LHsExpr GhcPs -> [Idea]+infixBracket fixities = f Nothing+  where+    msg = "Redundant bracket due to operator fixities"+    f p o = cur p o <> concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o]+    cur p v = do+      Just (i, o, gen) <- [p]+      Just x <- [remParen v]+      guard $ redundantInfixBracket fixities i o x+      pure $+        rawIdea Ignore msg (locA (getLoc v)) (unsafePrettyPrint o)+        (Just (unsafePrettyPrint (gen x))) [] [Replace (findType v) (toSSA v) [("x", toSSA x)] "x"]++redundantInfixBracket :: Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool+redundantInfixBracket fixities i parent child+    | L _ (OpApp _ _ (L _ (HsVar _ (L _ (Unqual p)))) _) <- parent+    , L _ (OpApp _ _ (L _ (HsVar _ (L _ (Unqual c)))) (L _ cr)) <- child =+    let (lop, rop)+            | i == 0 = (c, p)+            | otherwise = (p, c)+    in+    case compareFixity <$> (fixities Data.Map.!? occNameString lop) <*> (fixities Data.Map.!? occNameString rop) of+    Just (False, r)+        | i == 0 -> not (needParenAsChild cr || r)+        | otherwise -> r+    _ -> False+    | otherwise = False++needParenAsChild :: HsExpr p -> Bool+needParenAsChild HsLet{} = True+needParenAsChild HsDo{} = True+needParenAsChild HsLam{} = True+needParenAsChild HsCase{} = True+needParenAsChild HsIf{} = True+needParenAsChild _ = False
src/Hint/Import.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-} {-     Reduce the number of import declarations.     Two import declarations can be combined if:@@ -28,118 +29,116 @@ 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 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 A (foo) \+import A (bar) \+import A (baz) -- import A ( foo, bar, baz ) </TEST> -}   module Hint.Import(importHint) where -import Control.Applicative-import Data.Tuple.Extra-import Hint.Type+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSSA,rawIdea) import Refact.Types hiding (ModuleName)-import qualified Refact.Types as R+import Refact.Types qualified as R+import Data.Tuple.Extra import Data.List.Extra+import Data.Generics.Uniplate.DataOnly import Data.Maybe+import Control.Applicative import Prelude +import GHC.Data.FastString+import GHC.Types.SourceText+import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.PkgQual -importHint :: ModuHint-importHint _ x = concatMap (wrap . snd) (groupSort-                 [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++-                 concatMap (\x -> hierarchy x ++ combine1 x) (universeBi x)+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +rawPkgQualToMaybe :: RawPkgQual -> Maybe StringLiteral+rawPkgQualToMaybe x =+  case x of+    NoRawPkgQual -> Nothing+    RawPkgQual lit -> Just lit -wrap :: [ImportDecl S] -> [Idea]-wrap o = [ rawIdea Warning "Use fewer imports" (srcInfoSpan $ ann $ head o) (f o) (Just $ f x) [] rs-         | Just (x, rs) <- [simplify o]]-    where f = unlines . map prettyPrint+importHint :: ModuHint+importHint _ ModuleEx {ghcModule=L _ HsModule{hsmodImports=ms}} =+  -- Ideas for combining multiple imports.+  concatMap (reduceImports . snd) (+    groupSort [((n, pkg), i) | i <- ms+              , ideclSource (unLoc i) == NotBoot+              , let i' = unLoc i+              , let n = unLoc $ ideclName i'+              , let pkg  = unpackFS . sl_fs <$> rawPkgQualToMaybe (ideclPkgQual i')]) +++  -- Ideas for removing redundant 'as' clauses.+  concatMap stripRedundantAlias ms +reduceImports :: [LImportDecl GhcPs] -> [Idea]+reduceImports [] = []+reduceImports ms@(m:_) =+  [rawIdea Hint.Type.Warning "Use fewer imports" (locA (getLoc m)) (f ms) (Just $ f x) [] rs+  | Just (x, rs) <- [simplify ms]]+  where f = unlines . map unsafePrettyPrint -simplify :: [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])+simplify :: [LImportDecl GhcPs]+         -> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan]) simplify [] = Nothing-simplify (x:xs) = case simplifyHead x xs of+simplify (x : xs) = case simplifyHead x xs of     Nothing -> first (x:) <$> simplify xs-    Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs-+    Just (xs, rs) ->+      let deletions = filter (\case Delete{} -> True; _ -> False) rs+       in Just $ maybe (xs, rs) (second (++ deletions)) $ simplify xs -simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])-simplifyHead x [] = Nothing-simplifyHead x (y:ys) = case combine x y of+simplifyHead :: LImportDecl GhcPs+             -> [LImportDecl GhcPs]+             -> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan])+simplifyHead x (y : ys) = case combine x y of     Nothing -> first (y:) <$> simplifyHead x ys     Just (xy, rs) -> Just (xy : ys, rs)---combine :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan])-combine x y | qual, as, specs = Just (x, [Delete Import (toSS y)])-           | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}-            in Just (newImp, [ Replace Import (toSS x)  [] (prettyPrint newImp)-                             , Delete Import (toSS y) ] )--           | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) =-             let (newImp, toDelete) = if isNothing (importSpecs x) then (x, y) else (y, x)-             in Just (newImp, [Delete Import (toSS toDelete)])-           | not (importQualified x), qual, specs, length ass == 1 =-             let (newImp, toDelete) = if isJust (importAs x) then (x, y) else (y, x)-             in Just (newImp, [Delete Import (toSS toDelete)])+simplifyHead x [] = Nothing +combine :: LImportDecl GhcPs+        -> LImportDecl GhcPs+        -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])+combine x@(L loc x') y@(L _ y')+  -- Both (un/)qualified, common 'as', same names : Delete the second.+  | qual, as, specs = Just (x, [Delete Import (toSSA y)])+    -- Both (un/)qualified, common 'as', different names : Merge the+    -- second into the first and delete it.+  | qual, as+  , Just (False, xs) <- first (== EverythingBut) <$> ideclImportList x'+  , Just (False, ys) <- first (== EverythingBut) <$> ideclImportList y' =+      let newImp = L loc x'{ideclImportList = Just (Exactly, noLocA (unLoc xs ++ unLoc ys))}+      in Just (newImp, [Replace Import (toSSA x) [] (unsafePrettyPrint (unLoc newImp))+                       , Delete Import (toSSA y)])+  -- Both (un/qualified), common 'as', one has names the other doesn't+  -- : Delete the one with names.+  | qual, as, isNothing (ideclImportList x') || isNothing (ideclImportList y') =+       let (newImp, toDelete) = if isNothing (ideclImportList x') then (x, y) else (y, x)+       in Just (newImp, [Delete Import (toSSA toDelete)])+  -- Both unqualified, same names, one (and only one) has an 'as'+  -- clause : Delete the one without an 'as'.+  | 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 (toSSA toDelete)])+  -- No hints.+  | otherwise = Nothing     where-        qual = importQualified x == importQualified y-        as = importAs x `eqMaybe` importAs y-        ass = mapMaybe importAs [x,y]-        specs = importSpecs x `eqMaybe` importSpecs y--combine _ _ = Nothing--combine1 :: ImportDecl S -> [Idea]-combine1 i@ImportDecl{..}-    | Just (dropAnn importModule) == fmap dropAnn importAs-    = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]]-combine1 _ = []---newNames = let (*) = flip (,) in-    ["Control" * "Monad"-    ,"Data" * "Char"-    ,"Data" * "List"-    ,"Data" * "Maybe"-    ,"Data" * "Ratio"-    ,"System" * "Directory"--    -- Special, see bug https://code.google.com/archive/p/ndmitchell/issues/393-    -- ,"System" * "IO"--    -- Do not encourage use of old-locale/old-time over haskell98-    -- ,"System" * "Locale"-    -- ,"System" * "Time"-    ]---hierarchy :: ImportDecl S -> [Idea]-hierarchy i@ImportDecl{importModule=m@(ModuleName _ x),importPkg=Nothing} | Just y <- lookup x newNames-    =-    let newModuleName = y ++ "." ++ x-        r = [Replace R.ModuleName (toSS m) [] newModuleName] in-    [suggest "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r]---- import IO is equivalent to--- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_)-hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing}-    = [rawIdeaN Suggestion "Use hierarchical imports" (srcInfoSpan $ ann i) (trimStart $ prettyPrint i) (-          Just $ unlines $ map (trimStart . prettyPrint)-          [f "System.IO" Nothing, f "System.IO.Error" Nothing-          ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) []]-    where f a b = (desugarQual i){importModule=ModuleName an a, importSpecs=b}--hierarchy _ = []+        eqMaybe:: Eq a => Maybe (LocatedA a) -> Maybe (LocatedA a) -> Bool+        eqMaybe (Just x) (Just y) = x `eqLocated` y+        eqMaybe Nothing Nothing = True+        eqMaybe _ _ = False +        qual = ideclQualified x' == ideclQualified y'+        as = ideclAs x' `eqMaybe` ideclAs y'+        ass = mapMaybe ideclAs [x', y']+        specs = transformBi (const noSrcSpan) (ideclImportList x') ==+                    transformBi (const noSrcSpan) (ideclImportList y') --- import qualified X ==> import qualified X as X-desugarQual :: ImportDecl S -> ImportDecl S-desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}-              | otherwise = x+stripRedundantAlias :: LImportDecl GhcPs -> [Idea]+stripRedundantAlias x@(L _ i@ImportDecl {..})+  -- Suggest 'import M as M' be just 'import M'.+  | Just (unLoc ideclName) == fmap unLoc ideclAs =+      [suggest "Redundant as" (reLoc x) (noLoc i{ideclAs=Nothing} :: Located (ImportDecl GhcPs)) [RemoveAsKeyword (toSSA x)]]+stripRedundantAlias _ = []
src/Hint/Lambda.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ViewPatterns, PatternGuards #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-}  {-     Concept:@@ -8,7 +9,7 @@     Rules:     fun a = \x -> y  -- promote lambdas, provided no where's outside the lambda     fun x = y x  -- eta reduce, x /= mr and foo /= symbol-    \x -> y x  -- eta reduce+    \x -> y x ==> y -- eta reduce     ((#) x) ==> (x #)  -- rotate operators     (flip op x) ==> (`op` x)  -- rotate operators     \x y -> x + y ==> (+)  -- insert operator@@ -22,26 +23,34 @@ <TEST> f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a+a = \x -> x + x -- a x = x + x+f (Just a) = \a -> a + a -- f (Just _) a = a + a+f (Foo a b c) = \c -> c + c -- f (Foo a b _) c = c + c 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 a b = f a b c where g x y = h x y -- g = h+fun a b = let g x y = h x y in f a b c -- g = h 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 = (*) x f = foo (flip op x) -- (`op` x) f = foo (flip op x) -- @Message Use section+f = foo (flip x y) -- (`x` y) 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 (Prelude.*) x) -- (Prelude.* x) 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)@@ -56,6 +65,7 @@ f = a b (\x -> c x d)  -- (`c` d) yes = \x -> a x where -- a yes = \x y -> op y x where -- flip op+yes = \x y -> op z y x where -- flip (op z) f = \y -> nub $ reverse y where -- nub . reverse f = \z -> foo $ bar $ baz z where -- foo . bar . baz f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz@@ -69,110 +79,275 @@ foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f+foo = bar (\x -> shakeRoot </> "src" </> x) baz = bar (\x -> (x +)) -- (+)+xs `withArgsFrom` args = f args+foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z+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+yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file no = blah (\ x -> case x of A -> a x; B -> b x)+no = blah (\ x -> case x of A -> a x; x -> b x)+foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z+yes = blah (\ x -> (y, x)) -- (y,) yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)+yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v)+yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST $ action x) yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>) {-# 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)+f = {- generates a hint using hlint.yaml only -} map (flip (,) "a") "123"+f = {- generates a hint using hlint.yaml only -} map ((,) "a") "123"+f = map (\s -> MkFoo s 0 s) ["a","b","c"] </TEST> -}   module Hint.Lambda(lambdaHint) where -import Hint.Util-import Hint.Type+import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan) import Util import Data.List.Extra-import Data.Maybe-import qualified Data.Set as Set-import Refact.Types hiding (RType(Match))+import Data.Set (Set)+import Data.Set qualified as Set+import Refact.Types hiding (Match)+import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) +import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Hs+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuoteExpr, isVar, isDol, strToVar)+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat (isWildPat)+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+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.View  lambdaHint :: DeclHint-lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x)+lambdaHint _ _ x+    =  concatMap (uncurry lambdaExp) (universeParentBi x)+    ++ concatMap (uncurry lambdaBind) binds+  where+    binds =+        ( case x of+            -- Turn a top-level HsBind under a ValD into an LHsBind.+            -- Also, its refact type needs to be Decl.+            L loc (ValD _ bind) -> ((L loc bind, Decl) :)+            _ -> id+        )+            ((,Bind) <$> universeBi x) +lambdaBind :: LHsBind GhcPs -> RType -> [Idea]+lambdaBind+    o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =+        MG {mg_alts =+            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype+    | EmptyLocalBinds _ <- bind+    , isLambda $ fromParen origBody+    , null (universeBi pats :: [HsExpr GhcPs])+    = let (newPats, newBody) = fromLambda . lambda pats $ origBody+          (sub, tpl) = mkSubtsAndTpl newPats newBody+          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)+          gen ps = uncurry reform . fromLambda . lambda ps+          refacts = case newBody of+              -- https://github.com/alanz/ghc-exactprint/issues/97+              L _ HsCase{} -> []+              _ -> [Replace rtype (toSSA o) sub tpl]+       in [warn "Redundant lambda" (reLoc o) (gen pats origBody) refacts] -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+    | let (newPats, newBody) = etaReduce pats origBody+    , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind+    = let (sub, tpl) = mkSubtsAndTpl newPats newBody+       in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody)+            [Replace rtype (toSS $ reform pats origBody) sub tpl]+          ]+    where+          reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)+          reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $+             origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])} -lambdaDecl _ = []+          mkSubtsAndTpl newPats newBody = (sub, tpl)+            where+              (origPats, vars) = mkOrigPats (Just (rdrNameStr funName)) newPats+              sub = ("body", toSSA newBody) : zip vars (map toSSA newPats)+              tpl = unsafePrettyPrint (reform origPats varBody) -setSpanInfoEnd ssi (line, col) = ssi{srcInfoSpan = (srcInfoSpan ssi){srcSpanEndLine=line, srcSpanEndColumn=col}}+lambdaBind _ _ = [] +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 isQuasiQuoteExpr $ universe 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) -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-    , 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)+lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]+lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y))))+    | isSymOcc f -- is this an operator?+    , isAtom y+    , allowLeftSection $ occNameString f+    , not $ isTypeApp y+    = [suggest "Use section" (reLoc o) (reLoc to) [r]]+    where+        to :: LHsExpr GhcPs+        to = nlHsPar $ noLocA $ SectionL noExtField y oper+        r = Replace Expr (toSSA o) [("x", toSSA y)] ("(x " ++ unsafePrettyPrint origf ++ ")") +lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y)))+    | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f+    = [suggest "Use section" (reLoc o) (reLoc to) [r]]+    where+        to :: LHsExpr GhcPs+        to = nlHsPar $ noLocA $ SectionR noExtField origf y+        op = if isSymbolRdrName (unLoc f)+               then unsafePrettyPrint f+               else "`" ++ unsafePrettyPrint f ++ "`"+        var = if rdrNameStr f == "x" then "y" else "x"+        r = Replace Expr (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")") ---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 p o@(L _ (HsLam _ LamSingle _))+    | not $ any isOpApp p+    , (res, refact) <- niceLambdaR [] o+    , not $ isLambda res+    , not $ any isQuasiQuoteExpr $ 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 the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.+    , let from = case p of+              -- Avoid creating redundant bracket.+              Just p@(L _ (HsPar _ (L _ HsLam{})))+                | L _ HsPar{} <- res -> p+                | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p+              _ -> o+    = [(if isVar res then warn else suggest) name (reLoc from) (reLoc res) (refact $ toSSA from)]     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" (reLoc o) (reLoc (lambda pats body)) [Replace Expr (toSSA 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 = [(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"]}]+      (oPats, vars) = mkOrigPats Nothing pats+      subts = ("body", toSSA body) : zip vars (map toSSA pats)+      template = unsafePrettyPrint (lambda oPats varBody)++-- 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" (reLoc o) $ noLoc $ ExplicitTuple noAnn (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]))+                   | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) ->+                     let patLocs = fmap (locA . getLoc) ((unLoc . m_pats) oldmatch)+                         bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [locA (getLoc body)])+                                        $ grhssGRHSs (m_grhss oldmatch)+                         r | notNull patLocs && notNull bodyLocs =+                             let xloc = foldl1' combineSrcSpans patLocs+                                 yloc = foldl1' combineSrcSpans bodyLocs+                              in [ Replace Expr (toSSA o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)]+                                     ((if needParens then "\\(x)" else "\\x") ++ " -> y")+                                 ]+                           | otherwise = []+                         needParens = any (patNeedsParens appPrec . unLoc) ((unLoc . m_pats) oldmatch)+                      in [ suggest "Use lambda" (reLoc o)+                             ( noLoc $ HsLam noAnn LamSingle oldMG+                                 { mg_alts = noLocA+                                     [ noLocA oldmatch+                                         { m_pats = L noSpanAnchor (map mkParPat $ (unLoc . m_pats) oldmatch)+                                         , m_ctxt = LamAlt LamSingle+                                         }+                                     ]+                                 }+                               :: Located (HsExpr GhcPs)+                             )+                             r+                         ]++                 -- otherwise we should use @LambdaCase@+                 MG _ (L _ _) ->+                     [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLam noAnn LamCase 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 :: HsTupArg GhcPs -> HsTupArg GhcPs+        removeX (Present _ (view -> Var_ x'))+            | x == x' = Missing noAnn+        removeX y = y+        -- | Extract the name of an argument of a tuple if it's present and a variable.+        tupArgVar :: HsTupArg GhcPs -> Maybe String+        tupArgVar (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)++-- | For each pattern, if it does not contain wildcards, replace it with a variable pattern.+--+-- The second component of the result is a list of substitution variables, which are guaranteed+-- to not occur in the function name or patterns with wildcards. For example, given+-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are not usable as substitution variables.+mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])+mkOrigPats funName pats = (zipWith munge vars pats', vars)+  where+    (Set.unions -> used, pats') = unzip (map f pats)++    -- Remove variables that occur in the function name or patterns with wildcards+    vars = filter (\s -> s `Set.notMember` used && Just s /= funName) substVars++    -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))+    f :: LPat GhcPs -> (Set String, (Bool, LPat GhcPs))+    f p+      | any isWildPat (universe p) =+          let used = Set.fromList [rdrNameStr name | (L _ (VarPat _ name)) <- universe p]+           in (used, (True, p))+      | otherwise = (mempty, (False, p))++    -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.+    munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs+    munge _ (True, p) = p+    munge ident (False, L ploc _) = L ploc (VarPat noExtField (noLocA $ mkRdrUnqual $ mkVarOcc ident))
src/Hint/List.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}- {-     Find and match: @@ -31,164 +31,259 @@ foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]] foo = [fooValue | Foo{..} <- y, fooField] issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd]+{-# LANGUAGE MonadComprehensions #-}\+foo = [x | False, x <- [1 .. 10]] -- []+foo = [_ | x <- _, let _ = A{x}]+issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []]+{-# LANGUAGE OverloadedLists #-} \+issue114 = True:[] </TEST> -}  module Hint.List(listHint) where  import Control.Applicative-import Hint.Type+import Data.Generics.Uniplate.DataOnly+import Data.List.NonEmpty qualified as NE import Data.List.Extra import Data.Maybe import Prelude++import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments,firstDeclComments)+ import Refact.Types hiding (SrcSpan)-import qualified Refact.Types as R+import Refact.Types qualified as R +import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.Name.Reader+import GHC.Data.FastString+import GHC.Builtin.Types +import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.Type+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader++ listHint :: DeclHint-listHint _ _ = listDecl+listHint _ modu = listDecl overloadedListsOn+  where+    -- Comments appearing without a line-break before the first+    -- declaration in a module are now associated with the declaration+    -- not the module so to be safe, look also at `firstDeclComments+    -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+    exts = concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu)))+    overloadedListsOn = "OverloadedLists" `elem` exts -listDecl :: Decl_ -> [Idea]-listDecl x =-    concatMap (listExp False) (childrenBi x) ++-    stringType x ++-    concatMap listPat (childrenBi x) ++-    concatMap listComp (universeBi x)+listDecl :: Bool -> LHsDecl GhcPs -> [Idea]+listDecl overloadedListsOn x =+  concatMap (listExp overloadedListsOn False) (childrenBi x) +++  stringType x +++  concatMap listPat (childrenBi x) +++  concatMap listComp (universeBi x) -listComp :: Exp_ -> [Idea]-listComp o@(ListComp a e xs)-    | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]-    | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]-    | xs /= ys = [suggest "Move guards forward" o o3 (suggestExpr o o3)]-    where+-- Refer to https://github.com/ndmitchell/hlint/issues/775 for the+-- structure of 'listComp'.++listComp :: LHsExpr GhcPs -> [Idea]+listComp o@(L _ (HsDo _ ListComp (L _ stmts))) =+  listCompCheckGuards o ListComp stmts+listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) =+  listCompCheckGuards o MonadComp stmts+listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi+listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) =+  listCompCheckMap o mp f ListComp stmts+listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =+  listCompCheckMap o mp f MonadComp stmts+listComp _ = []++listCompCheckGuards :: LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckGuards o ctx stmts =+  let revs = NE.reverse $ NE.fromList stmts+      e@(L _ LastStmt{}) = NE.head revs -- In a ListComp, this is always last.+      xs = reverse (NE.tail revs) in+  list_comp_aux e xs+  where+    list_comp_aux e xs+      | "False" `elem` cons =  [suggest "Short-circuited list comprehension" (reLoc o) (reLoc o') (suggestExpr o o')]+      | "True" `elem` cons = [suggest "Redundant True guards" (reLoc o) (reLoc o2) (suggestExpr o o2)]+      | not (astListEq xs ys) = [suggest "Move guards forward" (reLoc o) (reLoc o3) (suggestExpr o o3)]+      | otherwise = []+      where         ys = moveGuardsForward xs-        o' = List an []-        o2 = ListComp a e $ filter ((/= Just "True") . qualCon) xs-        o3 = ListComp a e ys+        o' = noLocA $ ExplicitList noAnn []+        o2 = noLocA $ HsDo noAnn ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e]))+        o3 = noLocA $ HsDo noAnn ctx (noLocA $ ys ++ [e])         cons = mapMaybe qualCon xs-        qualCon (QualStmt _ (Qualifier _ (Con _ x))) = Just $ fromNamed x+        qualCon :: ExprLStmt GhcPs -> Maybe String+        qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x)         qualCon _ = Nothing-listComp o@(view -> App2 mp f (ListComp a e xs)) | mp ~= "map" =-    [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]-    where o2 = ListComp a (App an (paren f) (paren e)) xs-listComp _ = [] -suggestExpr :: Exp_ -> Exp_ -> [Refactoring R.SrcSpan]-suggestExpr o o2 = [Replace Expr (toSS o) [] (prettyPrint o2)]---- Move all the list comp guards as far forward as they can go-moveGuardsForward :: [QualStmt S] -> [QualStmt S]-moveGuardsForward = reverse . f [] . reverse+listCompCheckMap ::+  LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea]+listCompCheckMap o mp f ctx stmts  | varToStr mp == "map" =+    [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)]     where-        f guards (x@(QualStmt _ (Generator _ p _)):xs) = reverse stop ++ x : f move xs-            where (move, stop) = span (if any isPFieldWildcard (universeS x) then const False else \x -> pvars p `disjoint` vars' x) guards-        f guards (x@(QualStmt _ Qualifier{}):xs) = f (x:guards) xs-        f guards (x@(QualStmt _ LetStmt{}):xs) = f (x:guards) xs-        f guards xs = reverse guards ++ xs+      revs = NE.reverse $ NE.fromList stmts+      L _ (LastStmt _ body b s) = NE.head revs -- In a ListComp, this is always last.+      last = noLocA $ LastStmt noExtField (noLocA $ HsApp noExtField (paren f) (paren body)) b s+      o2 =noLocA $ HsDo noAnn ctx (noLocA $ reverse (NE.tail revs) ++ [last]) -        -- the type QualStmt doesn't have a Var instance, so fake something that works-        vars' x = [prettyPrint a | Var _ a <- universeS x]+listCompCheckMap _ _ _ _ _ = [] +suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]+suggestExpr o o2 = [Replace Expr (toSSA o) [] (unsafePrettyPrint o2)] --- boolean = are you in a ++ chain-listExp :: Bool -> Exp_ -> [Idea]-listExp b (fromParen -> x) =-        if null res then concatMap (listExp $ isAppend x) $ children x else [head res]-    where-        res = [suggest name x x2 [r] | (name,f) <- checks-                                  , Just (x2, subts, temp) <- [f b x]-                                  , let r = Replace Expr (toSS x) subts temp ]+moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]+moveGuardsForward = reverse . f [] . reverse+  where+    f guards (x@(L _ (BindStmt _ p _)) : xs) = reverse stop ++ x : f move xs+      where (move, stop) =+              span (if any hasPFieldsDotDot (universeBi x)+                       || any isPFieldWildcard (universeBi x)+                      then const False+                      else \x ->+                       let pvs = 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.+                       pvs `disjoint` varss x && "pun-right-hand-side" `notElem` pvs+                   ) 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 -listPat :: Pat_ -> [Idea]-listPat x = if null res then concatMap listPat $ children x else [head res]-    where res = [suggest name x x2 [r]-                  | (name,f) <- pchecks+listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea]+listExp overloadedListsOn b (fromParen -> x) =+  if null res+    then concatMap (listExp overloadedListsOn $ isAppend x) $ children x+    else [NE.head $ NE.fromList res]+  where+    res = [suggest name (reLoc x) (reLoc x2) [r]+          | (name, f) <- checks overloadedListsOn+          , Just (x2, subts, temp) <- [f b x]+          , let r = Replace Expr (toSSA x) subts temp ]++listPat :: LPat GhcPs -> [Idea]+listPat x = if null res then concatMap listPat $ children x else [NE.head $ NE.fromList res]+    where res = [suggest name (reLoc x) (reLoc x2) [r]+                  | (name, f) <- pchecks                   , Just (x2, subts, temp) <- [f x]-                  , let r = Replace Pattern (toSS x) subts temp ]+                  , let r = Replace Pattern (toSSA x) subts temp ] -isAppend (view -> App2 op _ _) = op ~= "++"+isAppend :: View a App2 => a -> Bool+isAppend (view -> App2 op _ _) = varToStr op == "++" isAppend _ = False --checks = let (*) = (,) in drop 1 -- see #174-    ["Use string literal" * useString-    ,"Use list literal" * useList-    ,"Use :" * useCons-    ]+checks :: Bool -> [(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]+checks overloadedListsOn = let (*) = (,) in drop1 -- see #174+  [ "Use string literal" * useString+  , "Use :" * useCons+  ]+  <> ["Use list literal" * useList | not overloadedListsOn ] -- see #114 -pchecks = let (*) = (,) in drop 1 -- see #174-    ["Use string literal pattern" * usePString-    ,"Use list literal pattern" * usePList+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 (PList _ xs) | xs /= [], Just s <- mapM fromPChar xs =-    let literal = PLit an (Signless an) $ String an s (show s)-    in Just (literal, [], prettyPrint literal)+usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String)+usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =+  let literal = noLocA $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) :: LPat GhcPs+  in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing +usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList =-        fmap  ( (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s))))-              . unzip-              )-        . f True ['a'..'z']-    where-        f first _ x | x ~= "[]" = if first then Nothing else Just []-        f first (ident: cs) (view -> PApp_ ":" [a,b]) =-          ((a, g ident a) :) <$> f False cs b-        f first _ _ = Nothing+  fmap  ( (\(e, s) ->+             (noLocA (ListPat noAnn e)+             , map (fmap toRefactSrcSpan . fst) s+             , unsafePrettyPrint (noLocA $ ListPat noAnn (map snd s) :: LPat GhcPs))+          )+          . unzip+        )+  . f True substVars+  where+    f first _ x | patToStr x == "[]" = if first then Nothing else Just []+    f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b+    f first _ _ = Nothing -        g :: Char -> Pat_ -> (String, Pat_)-        g c p = ([c], PVar (ann p) (toNamed [c]))+    g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)+    g s (locA . getLoc -> loc) = ((s, loc), noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit s))) -useString b (List _ xs) | xs /= [], Just s <- mapM fromChar xs =-  let literal = Lit an $ String an s (show s)-  in Just (literal , [], prettyPrint literal)-useString b _ = Nothing+useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)+useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs =+  let literal = noLocA (HsLit noExtField (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs+  in Just (literal, [], unsafePrettyPrint literal)+useString _ _ = Nothing +useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useList b =-        fmap  ( (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s))))-              . unzip-              )-        . f True ['a'..'z']-    where-        f first _ x | x ~= "[]" = if first then Nothing else Just []-        f first (ident:cs) (view -> App2 c a b) | c ~= ":" =+  fmap  ( (\(e, s) ->+             (noLocA (ExplicitList noAnn e)+             , map (fmap toSSA) s+             , unsafePrettyPrint (noLocA $ ExplicitList noAnn (map snd s) :: LHsExpr GhcPs))+          )+          . unzip+        )+  . f True substVars+  where+    f first _ x | varToStr x == "[]" = if first then Nothing else Just []+    f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" =           ((a, g ident a) :) <$> f False cs b-        f first _ _ = Nothing+    f first _ _ = Nothing -        g :: Char -> Exp_ -> (String, Exp_)-        g c p = ([c], toNamed [c])+    g :: String -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)+    g s p = (s, L (getLoc p) (unLoc $ strToVar s)) -useCons False (view -> App2 op x y) | op ~= "++"-                                    , Just (x2, build) <- f x+useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)+useCons False (view -> App2 op x y) | varToStr op == "++"+                                    , Just (newX, tplX, spanX) <- f x                                     , not $ isAppend y =-  Just (gen (build x2) y-       , [("x", toSS x2), ("xs", toSS y)]-       , prettyPrint $ gen (build $ toNamed "x") (toNamed "xs"))-    where-        f (List _ [x]) = Just (x, \v -> if isApp x then v else paren v)-        f _ = Nothing-+    Just (gen newX y+         , [("x", spanX), ("xs", toSSA y)]+         , unsafePrettyPrint $ gen tplX (strToVar "xs")+         )+  where+    f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)+    f (L _ (ExplicitList _ [x]))+      | isAtom x || isApp x = Just (x, strToVar "x", toSSA x)+      | otherwise = Just (addParen x, addParen (strToVar "x"), toSSA x)+    f _ = Nothing -        gen x = InfixApp an x (QConOp an $ list_cons_name an)+    gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+    gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField  (noLocA consDataCon_RDR))) useCons _ _ = Nothing ---typeListChar = TyList an (TyCon an (toNamed "Char"))-typeString = TyCon an (toNamed "String")+typeListChar :: LHsType GhcPs+typeListChar =+  noLocA $ HsListTy noAnn+    (noLocA (HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) +typeString :: LHsType GhcPs+typeString =+  noLocA $ HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) -stringType :: Decl_ -> [Idea]-stringType x = case x of-    InstDecl _ _ _ x -> f x-    _ -> f x-    where-        f x = concatMap g $ childrenBi x+stringType :: LHsDecl GhcPs  -> [Idea]+stringType (L _ x) = case x of+  InstD _ ClsInstD{+    cid_inst=+        ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->+    f x ++ f y ++ f z -- Pretty much everything but the instance type.+  _ -> f x+  where+    f x = concatMap g $ childrenBi x -        g :: Type_ -> [Idea]-        g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)-                                    rs | not . null $ rs]-            where f x = if x =~= typeListChar then typeString else x-                  rs = [Replace Type (toSS t) [] (prettyPrint typeString) | t <- universe x, t =~= typeListChar]+    g :: LHsType GhcPs -> [Idea]+    g e@(fromTyParen -> x) = [ignore "Use String" (reLoc x) (reLoc (transform f x))+                              rs | not . null $ rs]+      where f x = if astEq x typeListChar then typeString else x+            rs = [Replace Type (toSSA t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
src/Hint/ListRec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}  {- map f [] = []@@ -23,21 +24,43 @@ f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs f [] y = y; f (x:xs) y = f xs (f xs z)+fun [] = []; fun (x:xs) = f x xs ++ fun xs </TEST> -}   module Hint.ListRec(listRecHint) where -import Hint.Type-import Hint.Util+import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA)++import Data.Generics.Uniplate.DataOnly import Data.List.Extra import Data.Maybe import Data.Either.Extra import Control.Monad import Refact.Types hiding (RType(Match)) +import GHC.Types.SrcLoc+import GHC.Hs.Extension+import GHC.Hs.Pat+import GHC.Builtin.Types+import GHC.Hs.Type+import GHC.Types.Name.Reader+import GHC.Hs.Binds+import GHC.Hs.Expr+import GHC.Hs.Decls+import GHC.Types.Basic +import GHC.Parser.Annotation+import Language.Haskell.Syntax.Extension++import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+ listRecHint :: DeclHint listRecHint _ _ = concatMap f . universe     where@@ -47,125 +70,163 @@             (use,severity,x) <- matchListRec x             let y = addCase x             guard $ recursiveStr `notElem` varss y-            -- Maybe we can do better here maintaining source formatting?-            return $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)]-+            -- Maybe we can do better here maintaining source+            -- formatting?+            pure $ idea severity ("Use " ++ use) (reLoc o) (reLoc y) [Replace Decl (toSSA o) [] (unsafePrettyPrint y)] +recursiveStr :: String recursiveStr = "_recursive_"-recursive = toNamed recursiveStr---- recursion parameters, nil-case, (x,xs,cons-case)--- for cons-case delete any recursive calls with xs from them--- any recursive calls are marked "_recursive_"-data ListCase = ListCase [String] Exp_ (String,String,Exp_)-                deriving Show+recursive = strToVar recursiveStr +data ListCase =+  ListCase+    [String] -- recursion parameters+    (LHsExpr GhcPs)  -- nil case+    (String, String, LHsExpr GhcPs) -- cons case+-- For cons-case delete any recursive calls with 'xs' in them. Any+-- recursive calls are marked "_recursive_".  data BList = BNil | BCons String String-             deriving (Eq,Ord,Show)---- function name, parameters, list-position, list-type, body (unmodified)-data Branch = Branch String [String] Int BList Exp_-              deriving Show-+             deriving (Eq, Ord, Show) +data Branch =+  Branch+    String  -- function name+    [String]  -- parameters+    Int -- list position+    BList (LHsExpr GhcPs) -- list type/body  --------------------------------------------------------------------- -- MATCH THE RECURSION  -matchListRec :: ListCase -> Maybe (String,Severity,Exp_)-matchListRec o@(ListCase vs nil (x,xs,cons))--    | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":"-    , fromParen rhs =~= recursive, xs `notElem` vars lhs-    = Just $ (,,) "map" Warning $ appsBracket-        [toNamed "map", niceLambda [x] lhs, toNamed xs]-+matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs)+matchListRec o@(ListCase vs nil (x, xs, cons))+    -- Suggest 'map'?+    | [] <- 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]+    -- Suggest 'foldr'?     | [] <- vs, App2 op lhs rhs <- view cons-    , vars op `disjoint` [x,xs]-    , fromParen rhs == recursive, xs `notElem` vars lhs-    = Just $ (,,) "foldr" Suggestion $ appsBracket-        [toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs]--    | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive+    , xs `notElem` (vars op ++ vars lhs) -- the meaning of xs changes, see #793+    , astEq (fromParen rhs) recursive+    = Just $ (,,) "foldr" Suggestion $+      appsBracket [ strToVar "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, strToVar xs]+    -- Suggest 'foldl'?+    | [v] <- vs, view nil == Var_ v, (L _ (HsApp _ r lhs)) <- cons+    , astEq (fromParen r) recursive     , xs `notElem` vars lhs-    = Just $ (,,) "foldl" Suggestion $ appsBracket-        [toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs]--    | [v] <- vs, App _ ret res <- nil, isReturn ret, res ~= "()" || view res == Var_ v-    , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons-    , b1 == b2, r == recursive, xs `notElem` vars e-    , name <- "foldM" ++ ['_' | res ~= "()"]-    = Just $ (,,) name Suggestion $ appsBracket-        [toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs]-+    = Just $ (,,) "foldl" Suggestion $+      appsBracket [ strToVar "foldl", niceLambda [v,x] lhs, strToVar v, strToVar xs]+    -- Suggest 'foldM'?+    | [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 $+      appsBracket [strToVar name, niceLambda [v,x] e, strToVar v, strToVar xs]+    -- Nope, I got nothing ¯\_(ツ)_/¯.     | otherwise = Nothing +-- Very limited attempt to convert >>= to do, only useful for+-- 'foldM' / 'foldM_'.+asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]+asDo (view ->+       App2 bind lhs+         (L _ (HsLam _ LamSingle MG {+              mg_ext=FromSource+            , mg_alts=L _ [+                 L _ Match {  m_ctxt=(LamAlt LamSingle)+                            , m_pats=L _ [v@(L _ VarPat{})]+                            , m_grhss=GRHSs _+                                        [L _ (GRHS _ [] rhs)]+                                        (EmptyLocalBinds _)}]}))+      ) =+  [ noLocA $ BindStmt noAnn v lhs+  , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ]+asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts+asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] --- Very limited attempt to convert >>= to do, only useful for foldM/foldM_-asDo :: Exp_ -> [Stmt S]-asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs]-asDo (Do _ x) = x-asDo x = [Qualifier an x]  --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS -findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_)++findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs) findCase x = do-    FunBind _ [x1,x2] <- return x-    Branch name1 ps1 p1 c1 b1 <- findBranch x1-    Branch name2 ps2 p2 c2 b2 <- findBranch x2-    guard (name1 == name2 && ps1 == ps2 && p1 == p2)-    [(BNil, b1), (BCons x xs, b2)] <- return $ sortOn fst [(c1,b1), (c2,b2)]-    b2 <- transformAppsM (delCons name1 p1 xs) b2-    (ps,b2) <- return $ eliminateArgs ps1 b2+  -- Match a function binding with two alternatives.+  (L _ (ValD _ FunBind {fun_matches=+              MG{mg_ext=FromSource, mg_alts=+                     (L _+                            [ x1@(L _ Match{..}) -- Match fields.+                            , x2]), ..} -- Match group fields.+          , ..} -- Fun. bind fields.+      )) <- pure x -    let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b-    return (ListCase ps b1 (x,xs,b2)-           ,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing])+  Branch name1 ps1 p1 c1 b1 <- findBranch x1+  Branch name2 ps2 p2 c2 b2 <- findBranch x2+  guard (name1 == name2 && ps1 == ps2 && p1 == p2)+  [(BNil, b1), (BCons x xs, b2)] <- pure $ sortOn fst [(c1, b1), (c2, b2)]+  b2 <- transformAppsM (delCons name1 p1 xs) b2+  (ps, b2) <- pure $ eliminateArgs ps1 b2 +  let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.+      emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.+      gRHS e = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.+      gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.+      match e = Match{m_ext=noExtField,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.+      matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated OtherExpansion SkipPmc, ..} -- Match group.+      funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind. -delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_-delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do-    (pre, (view -> Var_ v):post) <- return $ splitAt pos xs-    guard $ v == var-    return $ apps $ recursive : pre ++ post-delCons _ _ _ x = return x+  pure (ListCase ps b1 (x, xs, b2), noLocA . 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) <- pure $ splitAt pos xs+    guard $ v == var+    pure $ apps $ recursive : pre ++ post+delCons _ _ _ x = pure x -eliminateArgs :: [String] -> Exp_ -> ([String], Exp_)+eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons)-    where-        args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive]-        elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False-        remove = concat . zipWith (\b x -> [x | not b]) elim+  where+    args = [zs | z : zs <- map fromApps $ universeApps cons, astEq z recursive]+    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) | x == recursive = apps $ x : remove xs-        f x = x+    f (fromApps -> x : xs) | astEq x recursive = apps $ x : remove xs+    f x = x   --------------------------------------------------------------------- -- FIND A BRANCH -findBranch :: Match S -> Maybe Branch-findBranch x = do-    Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x-    (a,b,c) <- findPat ps-    return $ Branch (fromNamed name) a b c $ simplifyExp bod +findBranch :: LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch+findBranch (L _ x) = do+  Match { m_ctxt = FunRhs {mc_fun=(L _ name)}+            , m_pats = ps+            , m_grhss =+              GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]+                        , grhssLocalBinds=EmptyLocalBinds _+                        }+            } <- pure x+  (a, b, c) <- findPat (unLoc ps)+  pure $ Branch (occNameStr name) a b c $ simplifyExp body -findPat :: [Pat_] -> Maybe ([String], Int, BList)+findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList) findPat ps = do-    ps <- mapM readPat ps-    [i] <- return $ findIndices isRight ps-    let (left,[right]) = partitionEithers ps-    return (left, i, right)+  ps <- mapM readPat ps+  [i] <- pure $ findIndices isRight ps+  let (left, [right]) = partitionEithers ps +  pure (left, i, right) -readPat :: Pat_ -> Maybe (Either String BList)+readPat :: LPat GhcPs -> Maybe (Either String BList) readPat (view -> PVar_ x) = Just $ Left x-readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs-readPat (PList _ []) = Just $ Right BNil+readPat (L _ (ParPat _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs))))))+ | n == consDataCon_RDR = Just $ Right $ BCons x xs+readPat (L _ (ConPat _ (L _ n) (PrefixCon [] [])))+  | n == nameRdrName nilDataConName = Just $ Right BNil readPat _ = Nothing
src/Hint/Match.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-}  {- The matching does a fairly simple unification between the two terms, treating@@ -7,7 +9,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@@ -39,175 +40,240 @@  module Hint.Match(readMatch) where -import Control.Applicative-import Data.List.Extra-import Data.Maybe-import Config.Type-import Hint.Type-import Control.Monad-import Data.Tuple.Extra-import HSE.Unify+import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSSA)+ import Util import Timing-import qualified Data.Set as Set-import Prelude-import qualified Refact.Types as R---fmapAn = fmap (const an)+import Data.Set qualified as Set+import Refact.Types qualified as R +import Control.Monad+import Data.Tuple.Extra+import Data.Maybe+import Config.Type+import Data.Generics.Uniplate.DataOnly ------------------------------------------------------------------------- READ THE RULE+import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import Data.Data+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader -readMatch :: [HintRule] -> DeclHint+readMatch :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch settings = findIdeas (concatMap readRule settings) - readRule :: HintRule -> [HintRule]-readRule m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)} =-    (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ do-        (l,v1) <- dotVersion hintRuleLHS-        (r,v2) <- dotVersion hintRuleRHS-        guard $ v1 == v2 && l /= [] && (length l > 1 || length r > 1) && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)-        if r /= [] then-            [m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide}-            ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]-         else if length l > 1 then-            [m{hintRuleLHS=dotApps l, hintRuleRHS=toNamed "id", hintRuleSide=hintRuleSide}-            ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]-         else []+readRule m@HintRule{ hintRuleLHS=(stripLocs . unextendInstances -> hintRuleLHS)+                    , hintRuleRHS=(stripLocs . unextendInstances -> hintRuleRHS)+                    , hintRuleSide=((stripLocs . unextendInstances <$>) -> hintRuleSide)+                    } =+   (:) 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 hintRuleSide ++ l ++ r))+    if not (null r) then+      [ 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{ 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 :: Exp_ -> [([Exp_], String)]+-- 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 (App l ls rs) = first (ls :) <$> dotVersion (fromParen rs)-dotVersion (InfixApp l x op y) = (first (LeftSection l x op :) <$> dotVersion y) ++-                                 (first (RightSection l op y:) <$> dotVersion x)-dotVersion _ = []+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 (L l (SectionL noExtField x op)) -- (a == )+      rSec = addParen (L 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 -> Module S -> Decl_ -> [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}-    | decl <- findDecls decl-    , (parent,x) <- universeParentExp decl-    , m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]-    , let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ]+    [ (idea (hintRuleSeverity m) (hintRuleName m) (reLoc x) (reLoc y) [r]){ideaNote=notes}+    | (name, expr) <- findDecls decl+    , (parent,x) <- universeParentExp expr+    , m <- matches, Just (y, tpl, notes, subst) <- [matchIdea s name m parent x]+    , let r = R.Replace R.Expr (toSSA x) subst (unsafePrettyPrint tpl)+    ] -findDecls :: Decl_ -> [Decl_]-findDecls x@InstDecl{} = children x-findDecls RulePragmaDecl{} = [] -- often rules contain things that HLint would rewrite-findDecls x = [x]+-- | A list of root expressions, with their associated names+findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]+findDecls x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =+    [(fromMaybe "" $ bindName xs, x) | xs <- cid_binds, x <- childrenBi xs]+findDecls (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.+findDecls x = map (fromMaybe "" $ declName x,) $ childrenBi x -matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)])-matchIdea s decl HintRule{..} parent x = do-    let nm a b = scopeMatch (hintRuleScope,a) (s,b)-    u <- unifyExp nm True hintRuleLHS x-    u <- validSubst (=~=) u-    -- need to check free vars before unqualification, but after subst (with e)-    -- need to unqualify before substitution (with res)-    let e = substitute u hintRuleRHS-        res = addBracket parent $ performSpecial $ substitute u $ unqualify hintRuleScope s hintRuleRHS-    guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar) (freeVars hintRuleRHS))-            `Set.isSubsetOf` freeVars x-        -- check no unexpected new free variables+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 hintRuleLHS+      rhs = unextendInstances hintRuleRHS+      sa  = hintRuleScope+      nm a b = scopeMatch (sa, a) (sb, b) -    -- check it isn't going to get broken by QuasiQuotes as per #483-    -- if we have lambdas we might be moving, and QuasiQuotes, we might inadvertantly break free vars-    -- because quasi quotes don't show what free vars they make use of-    guard $ not (any isLambda $ universe hintRuleLHS) || not (any isQuasiQuote $ universe x)+  (u, extra) <- unifyExp nm True lhs x+  u <- validSubst astEq u -    guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : fromSubst u-    guard $ checkDefine decl parent res-    return (res, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, ann pos /= an])+  -- Need to check free vars before unqualification, but after subst+  -- (with 'e') need to unqualify before substitution (with 'res').+  let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp noExtField fun rhs)+           | otherwise = rhs+      (e, (tpl, substNoParens)) = 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+  -- we have lambdas we might be moving, and QuasiQuotes, we might+  -- inadvertantly break free vars because quasi quotes don't show+  -- what free vars they make use of.+  guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuoteExpr $ universe x)++  guard $ checkSide (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst u+  guard $ checkDefine declName parent rhs++  (u, tpl) <- pure $ if any ((== noSrcSpan) . locA . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl)+  tpl <- pure $ unqualify sa sb (addBracket parent $ performSpecial tpl)++  pure ( res, tpl, hintRuleNotes,+         [ (s, toSSA pos') | (s, pos) <- fromSubst u, locA (getLoc pos) /= noSrcSpan+                          , let pos' = if s `elem` substNoParens then fromParen pos else pos+         ]+       )+ --------------------------------------------------------------------- -- SIDE CONDITIONS -checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool+checkSide :: Maybe (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool checkSide x bind = maybe True bool x     where-        bool :: Exp_ -> Bool-        bool (InfixApp _ x op y)-            | opExp op ~= "&&" = bool x && bool y-            | opExp op ~= "||" = bool x || bool y-            | opExp op ~= "==" = expr (fromParen1 x) =~= expr (fromParen1 y)-        bool (App _ x y) | x ~= "not" = not $ bool y-        bool (Paren _ x) = bool x+      bool :: LHsExpr GhcPs -> Bool+      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 (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y+      bool (L _ (HsPar _ x)) = bool x -        bool (App _ cond (sub -> y))-            | 'i':'s':typ <- fromNamed cond = isType typ y-        bool (App _ (App _ cond (sub -> x)) (sub -> y))-            | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]-            | cond ~= "notEq" = x /=~= y-        bool x | x ~= "noTypeCheck" = True-        bool x | x ~= "noQuickCheck" = True-        bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x+      bool (L _ (HsApp _ cond (sub -> y)))+        | 'i' : 's' : typ <- varToStr cond = isType typ 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+      bool x | varToStr x == "noQuickCheck" = True+      bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ unsafePrettyPrint x -        expr :: Exp_ -> Exp_-        expr (App _ (fromNamed -> "subst") x) = sub $ fromParen1 x-        expr x = x+      expr :: LHsExpr GhcPs -> LHsExpr GhcPs+      expr (L _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1 x+      expr x = x -        isType "Compare" x = True -- just a hint for proof stuff-        isType "Atom" x = isAtom x-        isType "WHNF" x = isWHNF x-        isType "Wildcard" x = any isFieldWildcard $ universeS x-        isType "Nat" (asInt -> Just x) | x >= 0 = True-        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 ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ-        isType typ x = head (words $ show x) == typ+      isType "Compare" x = True -- Just a hint for proof stuff+      isType "Atom" x = isAtom x+      isType "WHNF" x = isWHNF x+      isType "Wildcard" x = any hasFieldsDotDot (universeBi x)+      isType "Nat" (asInt -> Just x) | x >= 0 = True+      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" (L _ (HsLit _ HsInt{})) = True+      isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{}))) = True+      isType "LitString" (L _ (HsLit _ HsString{})) = 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 -        asInt :: Exp_ -> Maybe Integer-        asInt (Paren _ x) = asInt x-        asInt (NegApp _ x) = negate <$> asInt x-        asInt (Lit _ (Int _ x _)) = Just x-        asInt _ = Nothing+      isType typ (L _ x) =+        let top = showConstr (toConstr x) in+        typ == top -        list :: Exp_ -> [Exp_]-        list (List _ xs) = xs-        list x = [x]+      asInt :: LHsExpr GhcPs -> Maybe Integer+      asInt (L _ (HsPar _ x)) = asInt x+      asInt (L _ (NegApp _ x _)) = negate <$> asInt x+      asInt (L _ (HsLit _ (HsInt _ (IL _ _ x)) )) = Just x+      asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x))))) = Just x+      asInt _ = Nothing -        sub :: Exp_ -> Exp_-        sub = transform f-            where f (view -> Var_ x) | Just y <- lookup x bind = y-                  f x = x+      list :: LHsExpr GhcPs -> [LHsExpr GhcPs]+      list (L _ (ExplicitList _ xs)) = xs+      list x = [x] +      sub :: LHsExpr GhcPs -> LHsExpr GhcPs+      sub = transform f+        where f (view -> Var_ x) | Just y <- lookup x bind = y+              f x = x --- does the result look very much like the declaration-checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool-checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y)+-- Does the result look very much like the declaration?+checkDefine :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool+checkDefine declName Nothing y =+  let funOrOp expr = (case expr of+        L _ (HsApp _ fun _) -> funOrOp fun+        L _ (OpApp _ _ op _) -> funOrOp op+        other -> other) :: LHsExpr GhcPs+   in declName /= varToStr (transformBi unqual $ funOrOp y) checkDefine _ _ _ = True - --------------------------------------------------------------------- -- TRANSFORMATION --- if it has _eval_ do evaluation on it-performSpecial :: Exp_ -> Exp_-performSpecial = transform fNoParen . fEval-    where-        fEval (App _ e x) | e ~= "_eval_" = reduce x-        fEval x = x--        fNoParen (App _ e x) | e ~= "_noParen_" = fromParen x-        fNoParen x = x+-- If it has '_noParen_', remove the brackets (if exist).+performSpecial :: LHsExpr GhcPs -> LHsExpr GhcPs+performSpecial = transform fNoParen+  where+    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 -> Exp_ -> Exp_+-- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.+unqualify :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify from to = transformBi f-    where-        f x@(UnQual _ (Ident _ s)) | isUnifyVar s = x-        f x = scopeMove (from,x) to-+  where+    f :: LocatedN RdrName -> LocatedN RdrName+    f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x+    f x = scopeMove (from, x) to -addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_-addBracket (Just (i,p)) c | needBracketOld i p c = Paren an c+addBracket :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs+addBracket (Just (i, p)) c | needBracketOld i p c = nlHsPar c addBracket _ x = x++-- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a+-- need to bracket type applications in  This doesn't come up in HSE+-- because the pretty printer inserts them.+addBracketTy :: LHsExpr GhcPs -> LHsExpr GhcPs+addBracketTy= transformBi f+  where+    f :: LHsType GhcPs -> LHsType GhcPs+    f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) =+      noLocA (HsAppTy noExtField t (noLocA (HsParTy noAnn x)))+    f x = x
src/Hint/Monad.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}  {-     Find and match:@@ -14,7 +20,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@@ -28,8 +34,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 ()@@ -40,160 +46,270 @@ 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 = f $ do g a $ sleep 10 -- g a $ sleep 10-main = do f a $ sleep 10 -- f a $ sleep 10-main = do foo x; return 3; bar z -- do foo x; bar z+{-# 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 -- @Ignore+main = do foo x; return 3; 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 -- do forM_ f xs; bar+main = void (forM_ f xs) -- forM_ f xs+main = void $ forM f xs -- forM_ f xs+main = void (forM f xs) -- 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+issue978 = do \+   print "x" \+   if False then main else do \+   return () </TEST> -}   module Hint.Monad(monadHint) where -import Control.Applicative+import Hint.Type++import GHC.Hs hiding (Warning)+import GHC.Types.Fixity+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import GHC.Data.Strict qualified++import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import GHC.Util++import Data.Generics.Uniplate.DataOnly import Data.Tuple.Extra import Data.Maybe import Data.List.Extra-import Hint.Type-import Refact.Types-import qualified Refact.Types as R-import Prelude+import Refact.Types hiding (Match)+import Refact.Types qualified as R  +badFuncs :: [String] badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"]+unitFuncs :: [String] unitFuncs = ["when","unless","void"] - monadHint :: DeclHint-monadHint _ _ d = concatMap (monadExp d) $ universeParentExp d--monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]-monadExp (fromNamed -> decl) (parent, x) = case x of-        (view -> App2 op x1 x2) | op ~= ">>" -> f x1-        (view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1-        App an op x | op ~= "void" -> seenVoid (App an op) x-        InfixApp an op dol x | op ~= "void", isDol dol -> seenVoid (InfixApp an op dol) x-        Do an [Qualifier _ y] -> [warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"] | not $ doOperator parent y]-        Do an xs ->-            monadSteps (Do an) xs ++-            [suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++-            concat [f x | Qualifier _ x <- init xs] ++-            concat [f x | Generator _ (PWildCard _) x <- init xs]-        _ -> []+monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d     where-        f = monadNoResult decl id-        seenVoid wrap x = monadNoResult decl wrap x ++ [warn "Redundant void" (wrap x) x [] | returnsUnit x]+        decl = declName d+        f parentDo parentExpr x =+            monadExp decl parentDo parentExpr x +++            concat [f (if isHsDo x then Just x else parentDo) (Just (i, x)) c | (i, c) <- zipFrom 0 $ children x] +        isHsDo (L _ HsDo{}) = True+        isHsDo _ = False  --- Sometimes people write a * do a + b, to avoid brackets-doOperator (Just (1, InfixApp _ _ op _)) InfixApp{} | not $ isDol op = True-doOperator _ _ = False+-- | Call with the name of the declaration,+--   the nearest enclosing `do` expression+--   the nearest enclosing expression+--   the expression of interest+monadExp :: Maybe String -> Maybe (LHsExpr GhcPs) -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]+monadExp decl parentDo parentExpr x =+  case x of+    (view -> App2 op x1 x2) | isTag ">>" op -> f x1+    (view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1+    (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (L l . HsApp noExtField op) x+    (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L 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 [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"]+          | not $ doAsBrackets parentExpr y+          , not $ doAsAvoidingIndentation parentDo x+          ]+    (L loc (HsDo _ (DoExpr mm) (L _ xs))) ->+      monadSteps (L loc . HsDo noAnn (DoExpr mm) . noLocA) xs +++      [suggest "Use let" (reLoc from) (reLoc to) [r] | (from, to, r) <- monadLet xs] +++      concat [f x | (L _ (BodyStmt _ x _ _)) <- dropEnd1 xs] +++      concat [f x | (L _ (BindStmt _ (L _ WildPat{}) x)) <- dropEnd1 xs]+    _ -> []+  where+    f = monadNoResult (fromMaybe "" decl) id+    seenVoid wrap (L l (HsPar x y)) = seenVoid (wrap . L l . \y -> HsPar x y) y+    seenVoid wrap x =+      -- Suggest `traverse_ f x` given `void $ traverse_ f x`+      [warn "Redundant void" (reLoc (wrap x)) (reLoc x) [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a"] | returnsUnit x]+        -- Suggest `traverse_ f x` given `void $ traverse f x`+        ++ ( case modifyAppHead+               ( \fun@(L l name) ->+                   ( if occNameStr name `elem` badFuncs+                       then L l (mkRdrUnqual (mkVarOcc (occNameStr name ++ "_")))+                       else fun,+                     fun+                   )+               )+               x of+               (x', Just fun@(L l name)) | occNameStr name `elem` badFuncs ->+                  let fun_ = occNameStr name ++ "_"+                   in [warn ("Use " ++ fun_) (reLoc (wrap x)) (reLoc x')+                        [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a",+                         Replace Expr (toSSA fun) [] fun_]]+               _ -> []+           )+    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) GHC.Data.Strict.Nothing +-- 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 :: Exp_ -> Bool-returnsUnit (Paren _ x) = returnsUnit x-returnsUnit (App _ x _) = returnsUnit x-returnsUnit (InfixApp _ x op _) | isDol op = returnsUnit x-returnsUnit (Var _ x) = any (x ~=) $ map (++ "_") badFuncs ++ unitFuncs-returnsUnit _ = False +-- Sometimes people write do, to avoid indentation, see+-- https://github.com/ndmitchell/hlint/issues/978+-- Return True if they are using do as avoiding indentation+doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool+doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L anna _)))) (L _ (HsDo _ _ (L annb _)))+  | EpAnn (EpaSpan (RealSrcSpan a _)) _ _ <- anna+  , EpAnn (EpaSpan (RealSrcSpan b _)) _ _ <- annb+  = srcSpanStartCol a == srcSpanStartCol b+doAsAvoidingIndentation parent self = False --- see through Paren and down if/case etc--- return the name to use in the hint, and the revised expression-monadNoResult :: String -> (Exp_ -> Exp_) -> Exp_ -> [Idea]-monadNoResult inside wrap (Paren l x) = monadNoResult inside (wrap . Paren l) x-monadNoResult inside wrap (App l x y) = monadNoResult inside (\x -> wrap $ App l x y) x-monadNoResult inside wrap (InfixApp l x op y)-    | isDol op = monadNoResult inside (\x -> wrap $ InfixApp l x op y) x-    | op ~= ">>=" = monadNoResult inside (wrap . InfixApp l x op) y+-- Apply a function to the application head, including `head arg` and `head $ arg`, which modifies+-- the head and returns a value. Sees through parentheses.+modifyAppHead :: forall a. (LIdP GhcPs -> (LIdP GhcPs, a)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)+modifyAppHead f = go id+  where+    go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)+    go wrap (L l (HsPar _ x)) = go (wrap . L l . \y -> HsPar noAnn y) x+    go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp noExtField x y)) x+    go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noExtField x op y)) x+    go wrap (L l (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a)+      where (x', a) = f x+    go _ expr = (expr, Nothing)++returnsUnit :: LHsExpr GhcPs -> Bool+returnsUnit = fromMaybe False+            . snd+            . modifyAppHead (\x -> (x, occNameStr (unLoc x) `elem` map (++ "_") badFuncs ++ unitFuncs))++-- 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 (L l (HsPar _ x)) = monadNoResult inside (wrap . nlHsPar) x+monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L 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 $ L l (OpApp noExtField x tag y)) x+    | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noExtField x tag) y monadNoResult inside wrap x-    | x2:_ <- filter (x ~=) badFuncs+    | x2 : _ <- filter (`isTag` x) badFuncs     , let x3 = x2 ++ "_"-    = [warn ("Use " ++ x3) (wrap x) (wrap $ toNamed x3) [Replace Expr (toSS x) [] x3] | inside /= x3]+    = [warn ("Use " ++ x3) (reLoc (wrap x)) (reLoc (wrap $ strToVar x3)) [Replace Expr (toSSA x) [] x3] | inside /= x3] monadNoResult inside wrap (replaceBranches -> (bs, rewrap)) =     map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat         [monadNoResult inside id b | b <- bs] --monadStep :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]+monadStep :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs)+           -> [ExprLStmt GhcPs] -> [Idea] --- do return x; $2 ==> do $2-monadStep wrap o@(Qualifier _ (fromRet -> Just (ret, _)):x:xs) =-    [warn ("Redundant " ++ ret) (wrap o) (wrap $ x:xs) [Delete Stmt (toSS (head o))]]+-- Rewrite 'do return x; $2' as 'do $2'.+monadStep wrap (o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))+  = [ideaRemove Warning ("Redundant " ++ ret) (locA (getLoc o)) (unsafePrettyPrint o) [Delete Stmt (toSSA o)]] --- do a <- $1; return a ==> do $1-monadStep wrap o@[g@(Generator _ (PVar _ p) x), q@(Qualifier _ (fromRet -> Just (ret, Var _ v)))]-    | fromNamed v == fromNamed p-    = [warn ("Redundant " ++ ret) (wrap o) (wrap [Qualifier an x])-            [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]+-- Rewrite 'do a <- $1; return a' as 'do $1'.+monadStep wrap o@[ g@(L _ (BindStmt _ (L _ (VarPat _ (L _ p))) x))+                  , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))]+  | occNameStr p == occNameStr v+  = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]))+      [Replace Stmt (toSSA g) [("x", toSSA x)] "x", Delete Stmt (toSSA q)]] --- do x <- $1; x; $2  ==> do join $1; $2-monadStep wrap o@(g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs)-    | p == v && v `notElem` varss xs-    = [warn "Use join" (wrap o) (wrap $ Qualifier an (rebracket1 $ App an (toNamed "join") x):xs) r]-    where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]+-- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.+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 = noLocA $ HsApp noExtField (strToVar "join") x+        body = noLocA $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr+        stmts = body : xs+    in [warn "Use join" (reLoc (wrap o)) (reLoc (wrap stmts)) r]+  where r = [Replace Stmt (toSSA g) [("x", toSSA x)] "join x", Delete Stmt (toSSA q)] --- do _ <- <return ()>; $1 ==> do <return ()>; $1-monadStep wrap o@(Generator an PWildCard{} x:rest)-    | returnsUnit x-    = [warn "Redundant variable capture" (wrap o) (wrap $ Qualifier an x : rest) []]+-- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as+-- 'do <return ()>; $1'.+monadStep wrap (o@(L loc (BindStmt _ p x)) : rest)+    | isPWildcard p, returnsUnit x+    = let body = L loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs+      in [warn "Redundant variable capture" (reLoc o) (reLoc body) [Replace Stmt (toSSA o) [("x", toSSA x)] "x"]] --- do <return ()>; return ()-monadStep wrap o@[Qualifier an x, Qualifier _ (fromRet -> Just (ret, unit))]-    | returnsUnit x, unit ~= "()"-    = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]+-- Redundant unit return : 'do <return ()>; return ()'.+monadStep+  wrap o@[ L _ (BodyStmt _ x _ _)+         , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _))]+     | returnsUnit x, occNameStr unit == "()"+  = [warn ("Redundant " ++ ret) (reLoc (wrap o)) (reLoc (wrap $ take 1 o)) [Delete Stmt (toSSA q)]] --- do x <- $1; return $ f $ g x ==> f . g <$> x+-- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap-    o@[g@(Generator _ (view -> PVar_ u) x)-      ,q@(Qualifier _ (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 [Qualifier an (InfixApp an (foldl' (flip (InfixApp an) (toNamed ".")) f fs) (toNamed "<$>") x)])-            [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 (InfixApp _ _ op _) = not $ isDol op-        notDol _ = True+  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 <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noExtField (foldl' (\acc e -> noLocA $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))+      [Replace Stmt (toSSA g) (("x", toSSA x):zip vs (toSSA <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSSA q)]]+  where+    isSimple (fromApps -> xs) = all isAtom (x : xs)+    vs = ('f':) . show <$> [0..] +    notDol :: LHsExpr GhcPs -> Bool+    notDol (L _ (OpApp _ _ op _)) = not $ isDol op+    notDol _ = True monadStep _ _ = []  -- Suggest removing a return-monadSteps :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]-monadSteps wrap (x:xs) = monadStep wrap (x:xs) ++ monadSteps (wrap . (x :)) xs+monadSteps :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]+monadSteps wrap (x : xs) = monadStep wrap (x : xs) ++ monadSteps (wrap . (x :)) xs monadSteps _ _ = [] +-- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'.+monadLet :: [ExprLStmt GhcPs] -> [(ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)]+monadLet xs = mapMaybe mkLet xs+  where+    vs = concatMap pvars [p | (L _ (BindStmt _ p _ )) <- xs] --- | do ...; x <- return y; ... ==> do ...; let x = y; ...-monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])-monadLet xs = if null rs then Nothing else Just (ys, rs)-    where-        (ys, catMaybes -> rs) = unzip $ map mkLet xs-        vs = concatMap pvars [p | Generator _ p _ <- xs]-        mkLet g@(Generator _ v@(view -> PVar_ p) (fromRet -> Just (_, y)))-            | p `notElem` vars y, p `notElem` delete p vs-            = (template (toNamed p) y, Just refact)-         where-            refact = Replace Stmt (toSS g) [("lhs", toSS v), ("rhs", toSS y)]-                      (prettyPrint $ template (toNamed "lhs") (toNamed "rhs"))-        mkLet x = (x, Nothing)-        template lhs rhs = LetStmt an $ BDecls an [PatBind an lhs (UnGuardedRhs an rhs) Nothing]+    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+      = Just (x, template p y, refact)+      where+        refact = Replace Stmt (toSSA x) [("lhs", toSSA v), ("rhs", toSSA y)]+                      (unsafePrettyPrint $ template "lhs" (strToVar "rhs"))+    mkLet _ = Nothing +    template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs+    template lhs rhs =+        let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)+            grhs = noLocA (GRHS noAnn [] rhs)+            grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)+            match = noLocA $ Match noExtField (FunRhs p Prefix NoSrcStrict noAnn) (noLocA []) grhss+            fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match]))+            binds = [fb]+            valBinds = ValBinds NoAnnSortKey binds []+            localBinds = HsValBinds noAnn valBinds+         in noLocA $ LetStmt noAnn localBinds -fromApplies :: Exp_ -> ([Exp_], Exp_)-fromApplies (App _ f x) = first (f:) $ fromApplies (fromParen x)-fromApplies (InfixApp _ f (isDol -> True) x) = first (f:) $ fromApplies x+fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)+fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x)+fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x) ---- | Match @return x@ to @Just x@.-fromRet :: Exp_ -> Maybe (String, Exp_)-fromRet (Paren _ x) = fromRet x-fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z-fromRet (App _ x y) | isReturn x = Just (prettyPrint x, y)+fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)+fromRet (L _ (HsPar _ x)) = fromRet x+fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLocA (HsApp noExtField x z)+fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/Naming.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-     Suggest the use of camelCase@@ -11,18 +13,20 @@     Also allow test_ as it's a standard tasty-th idiom     Also allow numbers separated by _     Also don't suggest anything mentioned elsewhere in the module+    Don't suggest for FFI, since they match their C names  <TEST>-data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest+data Yes = Foo | Bar'Test data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar 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 = ... no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1-semiring'laws = 1 -- semiringLaws = ...+semiring'laws = 1 data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB case_foo = 1 test_foo = 1@@ -31,69 +35,102 @@ _foo__ = 1 section_1_1 = 1 runMutator# = 1+foreign import ccall hexml_node_child :: IO () </TEST> -}   module Hint.Naming(namingHint) where -import Hint.Type-import Data.List.Extra+import Hint.Type (Idea,DeclHint,suggest,ghcModule)+import Data.Generics.Uniplate.DataOnly+import Data.List.Extra (nubOrd, isPrefixOf)+import Data.List.NonEmpty (toList) import Data.Data import Data.Char import Data.Maybe-import Refact.Types hiding (RType(Match))-import qualified Data.Set as Set+import Data.Set qualified as Set +import GHC.Types.Basic+import GHC.Types.SourceText+import GHC.Data.FastString+import GHC.Hs.Decls+import GHC.Hs.Extension+import GHC.Hs+import GHC.Types.Name.Occurrence+import GHC.Types.SrcLoc +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import GHC.Util+ namingHint :: DeclHint-namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ moduleDecls modu+namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ hsmodDecls $ unLoc (ghcModule modu) -naming :: Set.Set String -> Decl_ -> [Idea]-naming seen x = [suggest "Use camelCase" x' x2' [Replace Bind (toSS x) [] (prettyPrint x2)] | not $ null res]-    where res = [(n,y) | n <- nubOrd $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]-          x2 = replaceNames res x-          x' = shorten x-          x2' = shorten x2+naming :: Set.Set String -> LHsDecl GhcPs -> [Idea]+naming seen originalDecl =+    [ suggest "Use camelCase"+               (reLoc (shorten originalDecl))+               (reLoc (shorten replacedDecl))+               [ -- https://github.com/mpickering/apply-refact/issues/39+               ]+    | not $ null suggestedNames+    ]+    where+        suggestedNames =+            [ (originalName, suggestedName)+            | not $ isForD originalDecl+            , originalName <- nubOrd $ getNames originalDecl+            , Just suggestedName <- [suggestName originalName]+            , not $ suggestedName `Set.member` seen+            ]+        replacedDecl = replaceNames suggestedNames originalDecl +shorten :: LHsDecl GhcPs -> LHsDecl GhcPs+shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) =+    L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})+shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) =+    L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}})+shorten x = x -shorten :: Decl_ -> Decl_-shorten x = case x of-    FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d]-    PatBind a b c _ -> f (PatBind a b) c-    x -> x+shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)+shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =+    L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}}++shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)+shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =+    L locGRHS (GRHS ttg0 guards (L locExpr dots))     where-        dots = Var an ellipses-        f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing-        f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing+        dots :: HsExpr GhcPs+        dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) +getNames :: LHsDecl GhcPs -> [String]+getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) -getNames :: Decl_ -> [String]-getNames x = case x of-    FunBind{} -> name-    PatBind{} -> name-    TypeDecl{} -> name-    DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]-    GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ _ _ _ <- cons]-    TypeFamDecl{} -> name-    DataFamDecl{} -> name-    ClassDecl{} -> name+getConstructorNames :: HsDecl GhcPs -> [String]+getConstructorNames tycld = case tycld of+    (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (NewTypeCon con) _))) -> conNames [con]+    (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ (DataTypeCons _ cons) _))) -> conNames cons     _ -> []-    where-        name = [fromNamed x]+  where+    conNames :: [LConDecl GhcPs] -> [String]+    conNames =  concatMap (map unsafePrettyPrint . conNamesInDecl . unLoc) -        f (ConDecl _ x _) = [x]-        f (InfixConDecl _ _ x _) = [x]-        f (RecDecl _ x _) = [x]+    conNamesInDecl :: ConDecl GhcPs -> [LIdP GhcPs]+    conNamesInDecl ConDeclH98  {con_name  = name}  = [name]+    conNamesInDecl ConDeclGADT {con_names = names} = Data.List.NonEmpty.toList names +isSym :: String -> Bool+isSym (x:_) = not $ isAlpha x || x `elem` "_'"+isSym _ = False  suggestName :: String -> Maybe String-suggestName x-    | isSym x || good || not (any isLower x) || any isDigit x ||-        any (`isPrefixOf` x) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing-    | otherwise = Just $ f x+suggestName original+    | isSym original || good || not (any isLower original) || any isDigit original ||+        any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_","tasty_"] = Nothing+    | otherwise = Just $ f original     where-        good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' x+        good = all isAlphaNum $ drp '_' $ drp '#' $ reverse $ filter (/= '\'') $ drp '_' original         drp x = dropWhile (== x)          f xs = us ++ g ys@@ -105,8 +142,8 @@                  | otherwise = g xs         g [] = [] --replaceNames :: Data a => [(String,String)] -> a -> a-replaceNames rep = transformBi f-    where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep-          f x = x+replaceNames :: Data a => [(String, String)] -> a -> a+replaceNames rep = transformBi replace+    where+        replace :: OccName -> OccName+        replace (unsafePrettyPrint -> name) = mkOccName srcDataName $ fromMaybe name $ lookup name rep
+ src/Hint/Negation.hs view
@@ -0,0 +1,62 @@+{-++Raise a warning if negation precedence may appear ambiguous to human readers.++<TEST>+yes = -1 ^ 2 -- @Suggestion -(1 ^ 2)+yes = -x ^ y -- @Suggestion -(x ^ y)+yes = -5 `plus` 3 -- @Suggestion -(5 `plus` 3)+yes = -f x `mod` y -- @Suggestion -(f x `mod` y)+yes = -x `mod` y -- @Suggestion -(x `mod` y)+no = -(5 + 3)+no = -5 + 3+no = -(f x)+no = -x+</TEST>+-}++module Hint.Negation(negationParensHint) where++import Hint.Type(DeclHint,Idea(..),rawIdea,toSSA)+import Config.Type+import Data.Generics.Uniplate.DataOnly+import Refact.Types+import GHC.Hs+import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import GHC.Types.SrcLoc++-- | See [motivating issue #1484](https://github.com/ndmitchell/hlint/issues/1484).+--+-- == Implementation note+--+-- The original intention was to compare fixities so as+-- to only fire the rule when the operand of prefix negation+-- has higher fixity than the negation itself (fixity 6).+--+-- However, since there do not exist any numerically-valued+-- operators with lower fixity than 6+-- (see [table](https://www.haskell.org/onlinereport/decls.html#sect4.4.2)),+-- we do not have to worry about fixity comparisons.+negationParensHint :: DeclHint+negationParensHint _ _ x =+  concatMap negatedOp (universeBi x :: [LHsExpr GhcPs])++negatedOp :: LHsExpr GhcPs -> [Idea]+negatedOp e =+  case e of+    L b1 (NegApp a1 inner@(L _ OpApp {}) a2) ->+      pure $+        rawIdea+          Suggestion+          "Parenthesize unary negation"+          (locA (getLoc e))+          (unsafePrettyPrint e)+          (Just renderedNewExpr)+          []+          [Replace (findType e) (toSSA e) [] renderedNewExpr]+        where+          renderedNewExpr = unsafePrettyPrint newExpr+          parenthesizedOperand = addParen inner+          newExpr = L b1 $ NegApp a1 parenthesizedOperand a2+    _ -> []
src/Hint/NewType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-     Suggest newtype instead of data for type declarations that have     only one field. Don't suggest newtype for existentially@@ -10,58 +11,172 @@ data Foo a b = Foo a -- newtype Foo a b = Foo a data Foo = Foo { field1, field2 :: Int} data S a = forall b . Show b => S b+{-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b+{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a . a) -- newtype Foo = Foo (forall a. a) data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a+data Foo a = () => Foo a -- newtype Foo a = () => Foo a data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int data A = A {b :: !C} -- newtype A = A {b :: C} data A = A Int#+data A = A (MutableByteArray# s) {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #)+{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)} data A = A () -- newtype A = A ()-newtype Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving newtype (Show, Eq)-newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo { getFoo :: Int } deriving newtype (Show, Eq)+newtype Foo = Foo Int deriving (Show, Eq) --+newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo Int deriving stock Show+data instance Foo Int = Bar Bool -- newtype instance Foo Int = Bar Bool+data instance Foo Int = Bar {field :: Bool} -- newtype instance Foo Int = Bar {field :: Bool}+data instance Foo Int = Bar {field :: Int#}+data instance Foo Int = Bar+data instance Foo Int = Bar {field1 :: Bool, field2 :: ()}+newtype instance Foo Int = Bar Bool deriving (Show, Eq) --+newtype instance Foo Int = Bar {field :: Bool} deriving Show --+newtype instance Foo Int = Bar {field :: Bool} deriving stock Show+{-# LANGUAGE RankNTypes #-}; data instance Foo Int = forall a. Show a => Foo a </TEST> -} module Hint.NewType (newtypeHint) where -import Hint.Type+import Hint.Type (Idea, DeclHint, Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion, suggestN) +import Data.List (isSuffixOf)+import GHC.Hs.Decls+import GHC.Hs+import GHC.Types.SrcLoc+import Data.Generics.Uniplate.Data+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+ newtypeHint :: DeclHint newtypeHint _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x -newtypeHintDecl :: Decl_ -> [Idea]-newtypeHintDecl x-    | Just (DataType s, t, f) <- singleSimpleField x-    = [(suggestN "Use newtype instead of data" x $ f (NewType s) $ fromTyBang t)-            {ideaNote = [DecreasesLaziness | not $ isTyBang t]}]+newtypeHintDecl :: LHsDecl GhcPs -> [Idea]+newtypeHintDecl old+    | Just WarnNewtype{newDecl, insideType} <- singleSimpleField old+    = [(suggestN "Use newtype instead of data" (reLoc old) (reLoc newDecl))+            {ideaNote = [DecreasesLaziness | warnBang insideType]}] newtypeHintDecl _ = [] +newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]+newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =+    [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]+newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl ((FamEqn _ _ _ _ _ dataDef)))))) =+    [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]+newTypeDerivingStrategiesHintDecl _ = [] -singleSimpleField :: Decl_ -> Maybe (DataOrNew S, Type_, DataOrNew S -> Type_ -> Decl_)-singleSimpleField (DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing Nothing ctor] x4)-    | Just (t, ft) <- f ctor = Just (dt, t, \dt t -> DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing Nothing $ ft t] x4)-    where-        f (ConDecl x1 x2 [t]) | not $ isKindHash t = Just (t, \t -> ConDecl x1 x2 [t])-        f (RecDecl x1 x2 [FieldDecl y1 [y2] t]) = Just (t, \t -> RecDecl x1 x2 [FieldDecl y1 [y2] t])-        f _ = Nothing+-- | Determine if the given data definition should use deriving strategies.+shouldSuggestStrategies :: HsDataDefn GhcPs -> Bool+shouldSuggestStrategies dataDef = not (isData dataDef) && not (hasAllStrategies dataDef)++hasAllStrategies :: HsDataDefn GhcPs -> Bool+hasAllStrategies (HsDataDefn _ _ _ _ _  xs) = all hasStrategyClause xs++isData :: HsDataDefn GhcPs -> Bool+isData (HsDataDefn _ _ _ _ (NewTypeCon _) _) = False+isData (HsDataDefn _ _ _ _ (DataTypeCons _ _) _) = True++hasStrategyClause :: LHsDerivingClause GhcPs -> Bool+hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True+hasStrategyClause _ = False++data WarnNewtype = WarnNewtype+    { newDecl :: LHsDecl GhcPs+    , insideType :: HsType GhcPs+    }++-- | Given a declaration, returns the suggested \"newtype\"ized declaration following these guidelines:+-- * Types ending in a \"#\" are __ignored__, because they are usually unboxed primitives - @data X = X Int#@+-- * @ExistentialQuantification@ stuff is __ignored__ - @data X = forall t. X t@+-- * Constructors with (nonempty) constraints are __ignored__ - @data X a = (Eq a) => X a@+-- * Single field constructors get newtyped - @data X = X Int@ -> @newtype X = X Int@+-- * Single record field constructors get newtyped - @data X = X {getX :: Int}@ -> @newtype X = X {getX :: Int}@+-- * All other declarations are ignored.+singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype+singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef)))+    | Just inType <- simpleHsDataDefn dataDef =+        case dropBangs dataDef of+          DataTypeCons False [con] ->+            Just WarnNewtype+              { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef+                  { dd_cons = NewTypeCon con }}+              , insideType = inType+              }+          DataTypeCons True [_] -> Nothing -- Extension "TypeData": `type data T x = ...`+          _ -> Nothing+singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl famEqn@(FamEqn _ _ _ _ _ dataDef)))))+    | Just inType <- simpleHsDataDefn dataDef =+        case dropBangs dataDef of+          DataTypeCons False [con] ->+            Just WarnNewtype+              { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ famEqn {feqn_rhs = dataDef+                      { dd_cons = NewTypeCon con }}+              , insideType = inType+              }+          DataTypeCons True [_] -> Nothing --  -- Extension "TypeData": `type data T x = ...`+          _ -> Nothing singleSimpleField _ = Nothing -newTypeDerivingStrategiesHintDecl :: Decl_ -> [Idea]-newTypeDerivingStrategiesHintDecl x = [ignoreN "Use DerivingStrategies" x new | Just new <- [newtypeDecl x]]+dropBangs :: HsDataDefn GhcPs -> DataDefnCons (LConDecl GhcPs)+dropBangs def =+  case dd_cons def of+    NewTypeCon a -> NewTypeCon (dropConsBang <$> a)+    DataTypeCons isTypeData as -> DataTypeCons isTypeData (map (dropConsBang <$>) as) -newtypeDecl :: Decl_ -> Maybe Decl_-newtypeDecl (DataDecl x1 x2@(NewType _) x3 x4 x5 x6)-    | any hasNoStrategy x6 = Just $ DataDecl x1 x2 x3 x4 x5 (withNewtype <$> x6)-newtypeDecl (GDataDecl x1 x2@(NewType _) x3 x4 x5 x6 x7)-    | any hasNoStrategy x7 = Just $ GDataDecl x1 x2 x3 x4 x5 x6 (withNewtype <$> x7)-newtypeDecl _ = Nothing+-- | Checks whether its argument is a \"simple\" data definition (see+-- 'singleSimpleField') returning the single thing under its+-- constructor if it is.+simpleHsDataDefn :: HsDataDefn GhcPs -> Maybe (HsType GhcPs)+simpleHsDataDefn (HsDataDefn _ _ _ _ (DataTypeCons _ [L _ constructor]) _) = simpleCons constructor+simpleHsDataDefn _ = Nothing -hasNoStrategy :: Deriving a -> Bool-hasNoStrategy (Deriving _ Nothing _) = True-hasNoStrategy _                      = False+-- | Checks whether its argument is a \"simple\" constructor (see criteria in 'singleSimpleField')+-- 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 [] [HsScaled _ (L _ inType)]) _)+    | emptyOrNoContext context+    , not $ isUnboxedTuple inType+    , not $ isHashy inType+    = Just inType+simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)+    | emptyOrNoContext context+    , not $ isUnboxedTuple inType+    , not $ isHashy inType+    = Just inType+simpleCons _ = Nothing -withNewtype :: Deriving a -> Deriving a-withNewtype (Deriving l Nothing rs)  = Deriving l (Just $ DerivNewtype l) rs-withNewtype d                        = d+isHashy :: HsType GhcPs -> Bool+isHashy x = or ["#" `isSuffixOf` unsafePrettyPrint v | v@HsTyVar{} <- universe x]++warnBang :: HsType GhcPs -> Bool+warnBang (HsBangTy _ (HsBang _ SrcStrict) _) = False+warnBang _ = True++emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool+emptyOrNoContext Nothing = True+emptyOrNoContext (Just (L _ [])) = True+emptyOrNoContext _ = False++-- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas!+dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs+-- fields [HsScaled GhcPs (LBangType GhcPs)]+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon [] fields) _) =+    -- decl {con_args = PrefixCon $ map getBangType fields}+    let fs' = map (\(HsScaled s lt) -> HsScaled s (getBangType lt)) fields  :: [HsScaled GhcPs (LBangType GhcPs)]+    in decl {con_args = PrefixCon [] fs'}+dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =+    decl {con_args = RecCon $ L recloc $ removeUnpacksRecords conDeclFields}+    where+        removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]+        removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)++        removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs+        removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =+            conDeclField {cd_fld_type = getBangType fieldType}+dropConsBang x = x++isUnboxedTuple :: HsType GhcPs -> Bool+isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True+isUnboxedTuple _ = False
+ src/Hint/NumLiteral.hs view
@@ -0,0 +1,119 @@+{-+    Suggest the usage of underscore when NumericUnderscores is enabled.++<TEST>+123456+{-# LANGUAGE NumericUnderscores #-} \+1234+{-# LANGUAGE NumericUnderscores #-} \+12345 -- @Suggestion 12_345 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+123456789.0441234e-123456 -- @Suggestion 123_456_789.044_123_4e-123_456 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+0x12abc.523defp+172345 -- @Suggestion 0x1_2abc.523d_efp+172_345 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+3.14159265359 -- @Suggestion 3.141_592_653_59 @NoRefactor+{-# LANGUAGE NumericUnderscores #-} \+12_33574_56+</TEST>++-}++module Hint.NumLiteral (numLiteralHint) where++import GHC.Hs+import GHC.Data.FastString+import GHC.LanguageExtensions.Type (Extension (..))+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Util.ApiAnnotation (extensions)+import Data.Char (isDigit, isOctDigit, isHexDigit)+import Data.List (intercalate)+import Data.Set (union)+import Data.Generics.Uniplate.DataOnly (universeBi)+import Refact.Types++import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments)+import Idea (Idea, suggest)++numLiteralHint :: DeclHint+numLiteralHint _ modu =+  -- Comments appearing without an empty line before the first+  -- declaration in a module are now associated with the declaration+  -- not the module so to be safe, look also at `firstDeclComments+  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+  let exts = union (extensions (modComments modu)) (extensions (firstDeclComments modu)) in+  if NumericUnderscores `elem` exts then+     concatMap suggestUnderscore . universeBi+  else+     const []++suggestUnderscore :: LHsExpr GhcPs -> [Idea]+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) =+  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]+  where+    underscoredSrcTxt = addUnderscore (unpackFS srcTxt)+    y :: LocatedAn NoEpAnns (HsExpr GhcPs)+    y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}}+    r = Replace Expr (toSSA x) [("a", toSSA y)] "a"+suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) =+  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ]+  where+    underscoredSrcTxt = addUnderscore (unpackFS srcTxt)+    y :: LocatedAn NoEpAnns (HsExpr GhcPs)+    y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}}+    r = Replace Expr (toSSA x) [("a", toSSA y)] "a"+suggestUnderscore _ = mempty++addUnderscore :: String -> String+addUnderscore intStr = numLitToStr underscoredNumLit+ where+   numLit = toNumLiteral intStr+   underscoredNumLit = numLit{ nl_intPart = underscoreFromRight chunkSize $ nl_intPart numLit+                             , nl_fracPart = underscore chunkSize $ nl_fracPart numLit+                             , nl_exp = underscoreFromRight 3 $ nl_exp numLit -- Exponential part is always decimal+                             }+   chunkSize = if null (nl_prefix numLit) then 3 else 4++   underscore chunkSize = intercalate "_" . chunk chunkSize+   underscoreFromRight chunkSize str+     | length str < 5 = str+     | otherwise = reverse . underscore chunkSize . reverse $ str+   chunk chunkSize [] = []+   chunk chunkSize xs = a:chunk chunkSize b where (a, b) = splitAt chunkSize xs++data NumLiteral = NumLiteral+  { nl_prefix :: String+  , nl_intPart :: String+  , nl_decSep :: String -- decimal separator+  , nl_fracPart :: String+  , nl_expSep :: String -- e, e+, e-, p, p+, p-+  , nl_exp :: String+  } deriving (Show, Eq)++toNumLiteral :: String -> NumLiteral+toNumLiteral str = case str of+  '0':'b':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0b"}+  '0':'B':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0B"}+  '0':'o':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0o"}+  '0':'O':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0O"}+  '0':'x':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0x"}+  '0':'X':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0X"}+  _              -> afterPrefix isDigit str+  where+    isBinDigit x = x == '0' || x == '1'++    afterPrefix isDigit str = (afterIntPart isDigit suffix){nl_intPart = intPart}+      where (intPart, suffix) = span isDigit str++    afterIntPart isDigit ('.':suffix) = (afterDecSep isDigit suffix){nl_decSep = "."}+    afterIntPart isDigit str = afterFracPart str++    afterDecSep isDigit str = (afterFracPart suffix){nl_fracPart = fracPart}+      where (fracPart, suffix) = span isDigit str++    afterFracPart str = NumLiteral "" "" "" "" expSep exp+      where (expSep, exp) = break isDigit str++numLitToStr :: NumLiteral -> String+numLitToStr (NumLiteral p ip ds fp es e) = p ++ ip ++ ds ++ fp ++ es ++ e
src/Hint/Pattern.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ViewPatterns, PatternGuards #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-}  {-     Improve the structure of code@@ -16,7 +17,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 -- foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x@@ -25,86 +26,82 @@ foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x+foo x | x < -2 * 3 = 4 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)+{-# 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) 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+{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y+{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x+{-# 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 -- _ 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+otherwise = True </TEST> -}   module Hint.Pattern(patternHint) where -import Hint.Type+import Hint.Type(DeclHint,Idea,modComments,firstDeclComments,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn)+import Data.Generics.Uniplate.DataOnly import Data.Function import Data.List.Extra import Data.Tuple import Data.Maybe import Data.Either-import Refact.Types hiding (RType(Pattern, Match))-import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)+import Refact.Types hiding (RType(Pattern, Match), SrcSpan)+import Refact.Types qualified as R (RType(Pattern, Match), SrcSpan) +import GHC.Hs hiding(asPattern)+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence+import GHC.Types.Basic hiding (Pattern)+import GHC.Data.Strict qualified +import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+ patternHint :: DeclHint-patternHint _ modu x =+patternHint _scope modu x =     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) (universeBi [p | PatBind _ p _ _ <- universe x]) ++-    concatMap (patHint strict True) (universeBi $ transform noPatBind x) +++    -- PatBind (used in 'let' and 'where') contains lazy-by-default+    -- patterns, everything else is strict.+    concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] +++    concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++     concatMap expHint (universeBi x)-    where-        noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c-        noPatBind x = x--        strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas modu, Ident _ n <- ns]-+  where+    -- Comments appearing without an empty line before the first+    -- declaration in a module are now associated with the declaration+    -- not the module so to be safe, look also at `firstDeclComments+    -- modu`+    -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+    exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu))) -- language extensions enabled at source+    strict = "Strict" `elem` exts -hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]-hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind)-    | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]]-    where rawGuards = asGuards bod-          mkGuard a = GuardedRhs an [Qualifier an a]-          guards = map (uncurry mkGuard) rawGuards-          (lhs, rhs) = unzip rawGuards-          mkTemplate c ps =-            -- Check if the expression has been injected or is natural-            let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p)-            in zipWith checkAn ps ['1' .. '9']-          patSubts = case pat of-                       [p] -> [Left p] -- Substitution doesn't work properly for PatBinds-                                       -- This will probably produce-                                       -- unexpected results if the pattern-                                       -- contains any template variables-                       ps  -> mkTemplate "p100" ps-          guardSubts = mkTemplate "g100" lhs-          exprSubts  = mkTemplate "e100" rhs-          templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts-          toString (Left e) = e-          toString (Right (v, _)) = toNamed v-          template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) [])-          f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]-          f = rights-          refactoring = Replace rtype (toRefactSrcSpan $ srcInfoSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template+    noPatBind :: LHsBind GhcPs -> LHsBind GhcPs+    noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLocA (WildPat noExtField)}+    noPatBind x = x  {- -- Do not suggest view patterns, they aren't something everyone likes sufficiently@@ -118,81 +115,136 @@         decsBind = nub $ concatMap declBind $ childrenBi bind -} -hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)-    | prettyPrint test `elem` ["otherwise","True"]-    = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]]+hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]+hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))+  | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs emptyComments guards bind)) [refactoring]]+  where+    rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]+    rawGuards = asGuards bod -hints gen (Pattern l t pats bod (Just bind)) | f bind-    = [gen "Redundant where" (Pattern l t pats bod Nothing) []]-    where-        f (BDecls _ x) = null x-        f (IPBinds _ x) = null x+    mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))+    mkGuard a = GRHS noAnn [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] -hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind)-    | prettyPrint test == "True"-    = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]]+    guards :: [LGRHS GhcPs (LHsExpr GhcPs)]+    guards = map (noLocA . uncurry mkGuard) rawGuards -hints _ _ = []+    (lhs, rhs) = unzip rawGuards +    mkTemplate c ps =+      -- Check if the expression has been injected or is natural.+      zipWith checkLoc ps ['1' .. '9']+      where+        checkLoc p@(L l _) v = if locA l == noSrcSpan then Left p else Right (c ++ [v], toSSA p) -asGuards :: Exp_ -> [(Exp S, Exp S)]-asGuards (Paren _ x) = asGuards x-asGuards (If _ a b c) = (a, b) : asGuards c-asGuards x = [(toNamed "otherwise", x)]+    patSubts =+      case pat of+        [p] -> [Left p] -- Substitution doesn't work properly for PatBinds.+                        -- This will probably produce unexpected results if the pattern contains any template variables.+        ps  -> mkTemplate "p100" ps+    guardSubts = mkTemplate "g100" lhs+    exprSubts  = mkTemplate "e100" rhs+    templateGuards = map noLocA (zipWith (mkGuard `on` toString) guardSubts exprSubts) +    toString (Left e) = e+    toString (Right (v, _)) = strToVar v+    toString' (Left e) = e+    toString' (Right (v, _)) = strToPat v -data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S))+    template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs emptyComments templateGuards bind)) []) --- Invariant: Number of patterns may not change-asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]-asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x)-    where-        decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (PatBind a pat rhs bind) rs)]-        decl (FunBind _ xs) = map match xs-        decl _ = []-        match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> suggest msg o (Match a b pat rhs bind) rs)-        match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> suggest msg o (InfixMatch a p b ps rhs bind) rs)-        alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (Alt a pat rhs bind) [])]+    f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]+    f = rights+    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=[noLocA (GRHS noAnn [] bod)]}) [Delete Stmt (toSSA test)]]+hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds+  = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]]+  where+    f :: HsLocalBinds GhcPs -> Bool+    f (HsValBinds _ (ValBinds _ l _)) = null l+    f (HsIPBinds _ (IPBinds _ l)) = null l+    f _ = False+    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) GHC.Data.Strict.Nothing+hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds))+  | unsafePrettyPrint test == "True"+  = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in+      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS noAnn [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]]+hints _ _ = [] +asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]+asGuards (L _ (HsPar _ x)) = asGuards x+asGuards (L _ (HsIf _ a b c)) = (a, b) : asGuards c+asGuards x = [(strToVar "otherwise", x)] --- 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_ -> [Idea]-patHint lang strict o@(PApp _ name args) | length args >= 3 && all isPWildCard args =-  [suggest "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ]-patHint lang strict o@(PVar _ v) | prettyPrint v == "otherwise" = [warn "Used otherwise as a pattern" o (PWildCard an) []]+data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) -patHint lang strict o@(PBangPat _ x) | strict, f x = [warn "Redundant bang pattern" o x [r]]-    where f (PParen _ x) = f x-          f (PAsPat _ _ x) = f x-          f PLit{} = True-          f PApp{} = True-          f PInfixApp{} = True-          f PTuple{} = True-          f PList{} = True-          f PRec{} = True-          f (PatTypeSig _ x _) = f x-          f _ = False-          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"-patHint False strict o@(PIrrPat _ x) | f x = [warn "Redundant irrefutable pattern" o x [r]]-    where f (PParen _ x) = f x-          f (PAsPat _ _ x) = f x-          f PWildCard{} = True-          f PVar{} = True-          f _ = False-          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"-patHint lang strict o@(PAsPat u v PWildCard{}) = [warn "Redundant as-pattern" o v []]-patHint _ _ _ = []+-- Invariant: Number of patterns may not change+asPattern :: LHsDecl GhcPs  -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]+asPattern (L loc x) = concatMap decl (universeBi x)+  where+    decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]+    decl o@(PatBind _ pat mult rhs) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind noExtField pat mult rhs) :: Located (HsBind 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@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noExtField ctx  (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs) -expHint :: Exp_ -> [Idea]-expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) =-  [suggest "Redundant case" o e [r]]+-- 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 -> LPat GhcPs -> [Idea]+patHint _ _ o@(L _ (ConPat _ name (PrefixCon _ args)))+  | length args >= 3 && all isPWildcard args =+  let rec_fields = HsRecFields noExtField [] Nothing :: HsRecFields GhcPs (LPat GhcPs)+      new        = noLocA $ ConPat noAnn name (RecCon rec_fields) :: LPat GhcPs+  in+  [suggest "Use record patterns" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]]+patHint _ _ o@(L _ (VarPat _ (L _ name)))+  | occNameString (rdrNameOcc name) == "otherwise" =+    [warn "Used otherwise as a pattern" (reLoc o) (noLoc (WildPat noExtField) :: Located (Pat GhcPs)) []]+patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))+  | strict, f x = [warn "Redundant bang pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]]   where-    r = Replace Expr (toSS o) [("x", toSS e)] "x"-expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing])-    | x =~= UnQual an y =-      [suggest "Redundant case" o e [r]]+    f :: Pat GhcPs -> Bool+    f (ParPat _ (L _ x)) = f x+    f (AsPat _ _ (L _ x)) = f x+    f LitPat {} = True+    f NPat {} = True+    f ConPat {} = True+    f TuplePat {} = True+    f ListPat {} = True+    f (SigPat _ (L _ p) _) = f p+    f _ = False+    r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x"+patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))+  | f x = [warn "Redundant irrefutable pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]]   where-    r = Replace Expr (toSS o) [("x", toSS e)] "x"+    f :: Pat GhcPs -> Bool+    f (ParPat _ (L _ x)) = f x+    f (AsPat _ _ (L _ x)) = f x+    f WildPat{} = True+    f VarPat{} = True+    f _ = False+    r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x"+patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =+  [warn "Redundant as-pattern" (reLoc o) (reLoc v) [Replace R.Pattern (toSSA o) [] (rdrNameStr v)]]+patHint _ _ _ = []++expHint :: LHsExpr GhcPs -> [Idea]+ -- Note the 'FromSource' in these equations (don't warn on generated match groups).+expHint o@(L _ (HsCase _ _ (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (WildPat _)]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) =+  [suggest "Redundant case" (reLoc o) (reLoc e) [r]]+  where+    r = Replace Expr (toSSA o) [("x", toSSA e)] "x"+expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (VarPat _ (L _ y))]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]))))+  | occNameStr x == occNameStr y =+      [suggest "Redundant case" (reLoc o) (reLoc e) [r]]+  where+    r = Replace Expr (toSSA o) [("x", toSSA e)] "x" expHint _ = []
src/Hint/Pragma.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+ {-     Suggest better pragmas     OPTIONS_GHC -cpp => LANGUAGE CPP@@ -7,109 +9,149 @@     OPTIONS_GHC -XFoo => LANGUAGE Foo     LANGUAGE A, A => LANGUAGE A     -- do not do LANGUAGE A, LANGUAGE B to combine+ <TEST> {-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS     -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}-{-# OPTIONS_GHC -fglasgow-exts #-} -- ???+{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor: refactor output has one LANGUAGE pragma per extension, while hlint suggestion has a single LANGUAGE pragma+{-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-} {-# 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 #-} {-# OPTIONS_GHC -cpp #-} \ {-# LANGUAGE CPP, Text #-} -- {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \-{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}+{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE EmptyCase, RebindableSyntax #-} </TEST> -}   module Hint.Pragma(pragmaHint) where -import Hint.Type+import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments,firstDeclComments) import Data.List.Extra+import Data.List.NonEmpty qualified as NE import Data.Maybe import Refact.Types-import qualified Refact.Types as R+import Refact.Types qualified as R +import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Data.FastString +import GHC.Util+import GHC.Driver.Session+ pragmaHint :: ModuHint-pragmaHint _ x = languageDupes lang ++ optToPragma x lang-    where-        lang = [x | x@LanguagePragma{} <- modulePragmas x]+pragmaHint _ modu =+  -- Comments appearing without a line-break before the first+  -- declaration in a module are now associated with the declaration+  -- not the module so to be safe, look also at `firstDeclComments+  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+  let ps = pragmas (modComments modu) ++ pragmas (firstDeclComments modu)+      opts = flags ps+      lang = languagePragmas ps in+    languageDupes lang ++ optToPragma opts lang -optToPragma :: Module_ -> [ModulePragma S] -> [Idea]-optToPragma x lang =-  [pragmaIdea (OptionsToComment old ys rs) | old /= []]+optToPragma :: [(LEpaComment, [String])]+             -> [(LEpaComment, [String])]+             -> [Idea]+optToPragma flags languagePragmas =+  [pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]   where-        (old,new,ns, rs) =-          unzip4 [(old,new,ns, r)-                 | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old ls]-                 , let r = mkRefact old new ns]+      (old, new, ns, rs) =+        unzip4 [(old, new, ns, r)+               | old <- flags, Just (new, ns) <- [optToLanguage old ls]+               , let r = mkRefact old new ns] -        ls = concat [map fromNamed n | LanguagePragma _ n <- lang]-        ns2 = nubOrd (concat ns) \\ ls+      ls = concatMap snd languagePragmas+      ns2 = nubOrd (concat ns) \\ ls -        ys = [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new-        mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan-        mkRefact old (maybe "" prettyPrint -> new) ns =-          let ns' = map (\n -> prettyPrint $ LanguagePragma an [toNamed n]) ns-          in-          ModifyComment (toSS old) (intercalate "\n" (filter (not . null) (new: ns')))+      dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1+      dummySpan = mkRealSrcSpan dummyLoc dummyLoc+      dummyAnchor = realSpanAsAnchor dummySpan -data PragmaIdea = SingleComment (ModulePragma S) (ModulePragma S)-                | MultiComment (ModulePragma S) (ModulePragma S) (ModulePragma S)-                | OptionsToComment [ModulePragma S] [ModulePragma S] [Refactoring R.SrcSpan]+      ys = [mkLanguagePragmas dummyAnchor ns2 | ns2 /= []] ++ catMaybes new+      mkRefact :: (LEpaComment, [String])+               -> Maybe LEpaComment+               -> [String]+               -> Refactoring R.SrcSpan+      mkRefact old (maybe "" comment_ -> new) ns =+        let ns' = map (\n -> comment_ (mkLanguagePragmas dummyAnchor [n])) ns+        in ModifyComment (toSSAnc (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new))) +data PragmaIdea = SingleComment LEpaComment LEpaComment+                 | MultiComment LEpaComment LEpaComment LEpaComment+                 | OptionsToComment (NE.NonEmpty LEpaComment) [LEpaComment] [Refactoring R.SrcSpan]  pragmaIdea :: PragmaIdea -> Idea pragmaIdea pidea =   case pidea of     SingleComment old new ->-      mkFewer (srcInfoSpan . ann $ old)-        (prettyPrint old) (Just $ prettyPrint new) []-        [ModifyComment (toSS old) (prettyPrint new)]+      mkFewer (getAncLoc old) (comment_ old) (Just $ comment_ new) []+      [ModifyComment (toSSAnc old) (comment_ new)]     MultiComment repl delete new ->-      mkFewer (srcInfoSpan . ann $ repl)-        (f [repl, delete]) (Just $ prettyPrint new) []-        [ ModifyComment (toSS repl) (prettyPrint new)-        , ModifyComment (toSS delete) ""]+      mkFewer (getAncLoc repl)+        (f [repl, delete]) (Just $ comment_ new) []+        [ ModifyComment (toSSAnc repl) (comment_ new)+        , ModifyComment (toSSAnc delete) ""]     OptionsToComment old new r ->-      mkLanguage (srcInfoSpan . ann . head $ old)-        (f old) (Just $ f new) []+      mkLanguage (getAncLoc . NE.head $ old)+        (f $ NE.toList old) (Just $ f new) []         r     where-          f = unlines . map prettyPrint-          mkFewer = rawIdea Warning "Use fewer LANGUAGE pragmas"-          mkLanguage = rawIdea Warning "Use LANGUAGE pragmas"-+          f = unlines . map comment_+          mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas"+          mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas" -languageDupes :: [ModulePragma S] -> [Idea]-languageDupes (a@(LanguagePragma _ x):xs) =-    (if nub_ x `neqList` x-        then [pragmaIdea (SingleComment a (LanguagePragma (ann a) $ nub_ x))]-        else [pragmaIdea (MultiComment a b (LanguagePragma (ann a) (nub_ $ x ++ y))) | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++-    languageDupes xs+languageDupes :: [(LEpaComment, [String])] -> [Idea]+languageDupes ( (a@(L l _), les) : cs ) =+  (if nubOrd les /= les+       then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]+       else [pragmaIdea (MultiComment a b (mkLanguagePragmas l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les']+  ) ++ languageDupes cs languageDupes _ = [] ---- Given a pragma, can you extract some language features out+-- Given a pragma, can you extract some language features out? strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]-strToLanguage "-fglasgow-exts" = Just $ map prettyExtension glasgowExts+strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags strToLanguage _ = Nothing --optToLanguage :: ModulePragma S -> [String] -> Maybe (Maybe (ModulePragma S), [String])-optToLanguage (OptionsPragma sl tool val) ls-    | maybe True (== GHC) tool && any isJust vs =-      Just (res, filter (not . (`elem` ls)) (concat $ catMaybes vs))-    where-        strs = words val-        vs = map strToLanguage strs-        keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs-        res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep)+-- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,+-- 'langexts' a list of all language extensions in the module enabled+-- by 'LANGUAGE' pragmas.+--+--  If ALL of the flags in the pragma enable language extensions,+-- 'return Nothing'.+--+-- If some (or all) of the flags enable options that are not language+-- extensions, compute a new options pragma with only non-language+-- extension enabling flags. Return that together with a list of any+-- language extensions enabled by this pragma that are not otherwise+-- enabled by LANGUAGE pragmas in the module.+optToLanguage :: (LEpaComment, [String])+               -> [String]+               -> Maybe (Maybe LEpaComment, [String])+optToLanguage (L loc _, flags) languagePragmas+  | any isJust vs =+      -- 'ls' is a list of language features enabled by this+      -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas+      -- in this module.+      let ls = concatMap (filter (`notElem` languagePragmas)) $ catMaybes vs in+      Just (res, ls)+  where+    -- Try reinterpreting each flag as a list of language features+    -- (e.g. via '-X'..., '-fglasgow-exts').+    vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]'+    -- Keep any flag that does not enable language extensions.+    keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags+    -- If there are flags to keep, 'res' is a new pragma setting just those flags.+    res = if null keep then Nothing else Just (mkFlags loc keep) optToLanguage _ _ = Nothing
src/Hint/Restrict.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  module Hint.Restrict(restrictHint) where @@ -8,95 +12,284 @@ foo = unsafePerformIO -- foo = bar `unsafePerformIO` baz -- module Util where otherFunc = unsafePerformIO $ print 1 ---module Util where exitMessageImpure = unsafePerformIO $ print 1+module Util where exitMessageImpure = System.IO.Unsafe.unsafePerformIO $ print 1 foo = unsafePerformOI+import Data.List.NonEmpty as NE \+foo = NE.nub (NE.fromList [1, 2, 3]) --+import Hypothetical.Module \+foo = nub s </TEST> -} -import qualified Data.Map as Map+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea,modComments,firstDeclComments) import Config.Type-import Hint.Type-import Data.List+import Util++import Data.Generics.Uniplate.DataOnly+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Map qualified as Map+import Data.List.Extra+import Data.List.NonEmpty (nonEmpty)+import Data.Either import Data.Maybe+import Data.Monoid import Data.Semigroup+import Data.Tuple.Extra import Control.Applicative+import Control.Monad+import Control.Monad.Extra import Prelude +import GHC.Hs+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Types.Name.Occurrence+import Language.Haskell.GhclibParserEx.GHC.Hs+import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader+import GHC.Util  -- FIXME: The settings should be partially applied, but that's hard to orchestrate right now restrictHint :: [Setting] -> ModuHint restrictHint settings scope m =-        checkPragmas modu (modulePragmas m) restrict ++-        maybe [] (checkImports modu $ moduleImports m) (Map.lookup RestrictModule restrict) ++-        maybe [] (checkFunctions modu $ moduleDecls m) (Map.lookup RestrictFunction restrict)+    -- Comments appearing without an empty line before the first+    -- declaration in a module are now associated with the declaration+    -- not the module so to be safe, look also at `firstDeclComments+    -- modu`+    -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).+    let annsMod = modComments m+        annsFirstDecl = firstDeclComments m+        ps   = pragmas annsMod ++ pragmas annsFirstDecl+        opts = flags ps+        exts = languagePragmas ps in+    checkPragmas modu opts exts rOthers +++    maybe [] (checkImports modu $ hsmodImports (unLoc (ghcModule m))) (Map.lookup RestrictModule rOthers) +++    checkFunctions scope modu (hsmodDecls (unLoc (ghcModule m))) rFunction     where-        modu = moduleName m-        restrict = restrictions settings+        modu = modName (ghcModule m)+        (rFunction, rOthers) = restrictions settings  --------------------------------------------------------------------- -- UTILITIES  data RestrictItem = RestrictItem     {riAs :: [String]+    ,riAsRequired :: Alt Maybe Bool+    ,riImportStyle :: Alt Maybe RestrictImportStyle+    ,riQualifiedStyle :: Alt Maybe QualifiedStyle     ,riWithin :: [(String, String)]+    ,riRestrictIdents :: RestrictIdents+    ,riMessage :: Maybe String     }+ instance Semigroup RestrictItem where-    RestrictItem x1 x2 <> RestrictItem y1 y2 = RestrictItem (x1<>y1) (x2<>y2)-instance Monoid RestrictItem where-    mempty = RestrictItem [] []-    mappend = (<>)+    RestrictItem x1 x2 x3 x4 x5 x6 x7+      <> RestrictItem y1 y2 y3 y4 y5 y6 y7+      = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4) (x5<>y5) (x6<>y6) (x7<>y7) -restrictions :: [Setting] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem)-restrictions settings = Map.map f $ Map.fromListWith (++) [(restrictType x, [x]) | SettingRestrict x <- settings]+-- Contains a map from module (Nothing if the rule is unqualified) to (within, message), so that we can+-- distinguish functions with the same name.+-- For example, this allows us to have separate rules for "Data.Map.fromList" and "Data.Set.fromList".+-- Using newtype rather than type because we want to define (<>) as 'Map.unionWith (<>)'.+newtype RestrictFunction = RestrictFun (Map.Map (Maybe String) ([(String, String)], Maybe String))++instance Semigroup RestrictFunction where+    RestrictFun m1 <> RestrictFun m2 = RestrictFun (Map.unionWith (<>) m1 m2)++type RestrictFunctions = (Bool, Map.Map String RestrictFunction)+type OtherRestrictItems = Map.Map RestrictType (Bool, Map.Map String RestrictItem)++restrictions :: [Setting] -> (RestrictFunctions, OtherRestrictItems)+restrictions settings = (rFunction, rOthers)     where+        (map snd -> rfs, ros) = partition ((== RestrictFunction) . fst) [(restrictType x, x) | SettingRestrict x <- settings]+        rFunction = (all restrictDefault rfs, Map.fromListWith (<>) [mkRf s r | r <- rfs, s <- restrictName r])+        mkRf s Restrict{..} = (name, RestrictFun $ Map.singleton modu (restrictWithin, restrictMessage))+          where+            -- Parse module and name from s. module = Nothing if the rule is unqualified.+            (modu, name) = first (fmap NonEmpty.init . NonEmpty.nonEmpty) (breakEnd (== '.') s)++        rOthers = Map.map f $ Map.fromListWith (++) (map (second pure) ros)         f rs = (all restrictDefault rs-               ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin) | Restrict{..} <- rs, s <- restrictName])+               ,Map.fromListWith (<>)+                  [(,) s RestrictItem+                    { riAs             = restrictAs+                    , riAsRequired     = restrictAsRequired+                    , riImportStyle    = restrictImportStyle+                    , riQualifiedStyle = restrictQualifiedStyle+                    , riWithin         = restrictWithin+                    , riRestrictIdents = restrictIdents+                    , riMessage        = restrictMessage+                    }+                  | Restrict{..} <- rs, s <- restrictName]) -ideaMayBreak w = w{ideaNote=[Note "may break the code"]}+ideaMessage :: Maybe String -> Idea -> Idea+ideaMessage (Just message) w = w{ideaNote=[Note message]}+ideaMessage Nothing w = w{ideaNote=[noteMayBreak]}++ideaNoTo :: Idea -> Idea ideaNoTo w = w{ideaTo=Nothing} -within :: String -> String -> RestrictItem -> Bool-within modu func RestrictItem{..} = any (\(a,b) -> (a == modu || a == "") && (b == func || b == "")) riWithin+noteMayBreak :: Note+noteMayBreak = Note "may break the code" +within :: String -> String -> [(String, String)] -> Bool+within modu func = any (\(a,b) -> (a ~= modu || a == "") && (b ~= func || b == ""))+  where (~=) = wildcardMatch+ --------------------------------------------------------------------- -- CHECKS -checkPragmas :: String -> [ModulePragma S] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) -> [Idea]-checkPragmas modu xs mps = f RestrictFlag "flags" onFlags ++ f RestrictExtension "extensions" onExtensions-    where-        f tag name sel =-            [ (if null good then ideaNoTo else id) $ ideaMayBreak $ warn ("Avoid restricted " ++ name) o (regen good) []-            | Just mp <- [Map.lookup tag mps]-            , o <- xs, Just (xs, regen) <- [sel o]-            , let (good, bad) = partition (isGood mp) xs, not $ null bad]+checkPragmas :: String+              -> [(LEpaComment, [String])]+              -> [(LEpaComment, [String])]+              ->  Map.Map RestrictType (Bool, Map.Map String RestrictItem)+              -> [Idea]+checkPragmas modu flags exts mps =+  f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts+  where+   f tag name xs =+     [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) (getAncLoc l) c Nothing [] []+     | Just (def, mp) <- [Map.lookup tag mps]+     , (l@(L _ (EpaComment (EpaBlockComment c) _)), les) <- xs+     , let (good, bad) = partition (isGood def mp) les+     , let note = maybe noteMayBreak Note . (=<<) riMessage . flip Map.lookup mp+     , let notes w = w {ideaNote=note <$> bad}+     , not $ null bad]+   isGood def mp x = maybe def (within modu "" . riWithin) $ Map.lookup x mp -        onFlags (OptionsPragma s t x) = Just (words x, OptionsPragma s t . unwords)-        onFlags _ = Nothing -        onExtensions (LanguagePragma s xs) = Just (map fromNamed xs, LanguagePragma (s :: S) . map toNamed)-        onExtensions _ = Nothing+-- | Extension to GHC's 'ImportDeclQualifiedStyle', expressing @qualifiedStyle: unrestricted@,+-- i.e. the preference of "either pre- or post-, but qualified" in a rule.+data QualifiedPostOrPre = QualifiedPostOrPre deriving Eq -        isGood (def, mp) x = maybe def (within modu "") $ Map.lookup x mp+checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea]+checkImports modu lImportDecls (def, mp) = mapMaybe getImportHint lImportDecls+  where+    getImportHint :: LImportDecl GhcPs -> Maybe Idea+    getImportHint i@(L _ ImportDecl{..}) = do+      let RestrictItem{..} = getRestrictItem def ideclName mp+      either (Just . ideaMessage riMessage) (const Nothing) $ do+        unless (within modu "" riWithin) $+          Left $ ideaNoTo $ warn "Avoid restricted module" (reLoc i) (reLoc i) [] +        let importedIdents = Set.fromList $+              case first (== EverythingBut) <$> ideclImportList of+                Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs)+                _ -> []+            invalidIdents = case riRestrictIdents of+              NoRestrictIdents -> Set.empty+              ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents+              OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents+        unless (Set.null invalidIdents) $+          Left $ ideaNoTo $ warn "Avoid restricted identifiers" (reLoc i) (reLoc i) [] -checkImports :: String -> [ImportDecl S] -> (Bool, Map.Map String RestrictItem) -> [Idea]-checkImports modu imp (def, mp) =-    [ ideaMayBreak $ if not allowImport-      then ideaNoTo $ warn "Avoid restricted module" i i []-      else warn "Avoid restricted qualification" i i{importAs=ModuleName an <$> listToMaybe riAs} []-    | i@ImportDecl{..} <- imp-    , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def]) (fromModuleName importModule) mp-    , let allowImport = within modu "" ri-    , let allowQual = maybe True (\x -> null riAs || fromModuleName x `elem` riAs) importAs-    , not allowImport || not allowQual-    ]+        let qualAllowed = case (riAs, ideclAs) of+              ([], _) -> True+              (_, Nothing) -> maybe True not $ getAlt riAsRequired+              (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs+        unless qualAllowed $ do+          let i' = noLoc $ (unLoc i){ ideclAs = noLocA . mkModuleName <$> listToMaybe riAs }+          Left $ warn "Avoid restricted alias" (reLoc i) i' [] +        let (expectedQual, expectedHiding) =+              case fromMaybe ImportStyleUnrestricted $ getAlt riImportStyle of+                ImportStyleUnrestricted+                  | NotQualified <- ideclQualified -> (Nothing, Nothing)+                  | otherwise -> (Just $ second (<> " or unqualified") expectedQualStyle, Nothing)+                ImportStyleQualified -> (Just expectedQualStyle, Nothing)+                ImportStyleExplicitOrQualified+                  | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing)+                  | otherwise ->+                      ( Just $ second (<> " or with an explicit import list") expectedQualStyle+                      , Nothing )+                ImportStyleExplicit+                  | Just (False, _) <- first (== EverythingBut) <$> ideclImportList -> (Nothing, Nothing)+                  | otherwise ->+                      ( Just (Right NotQualified, "unqualified")+                      , Just $ Just (Exactly, noLocA []) )+                ImportStyleUnqualified -> (Just (Right NotQualified, "unqualified"), Nothing)+            expectedQualStyle =+              case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of+                QualifiedStyleUnrestricted -> (Left QualifiedPostOrPre, "qualified")+                QualifiedStylePost -> (Right QualifiedPost, "post-qualified")+                QualifiedStylePre -> (Right QualifiedPre, "pre-qualified")+            -- unless expectedQual is Nothing, it holds the Idea (hint) to ultimately emit,+            -- except in these cases when the rule's requirements are fulfilled in-source:+            qualIdea+              -- the rule demands a particular importStyle, and the decl obeys exactly+              | Just (Right ideclQualified) == (fst <$> expectedQual) = Nothing+              -- the rule demands a QualifiedPostOrPre import, and the decl does either+              | Just (Left QualifiedPostOrPre) == (fst <$> expectedQual)+                && ideclQualified `elem` [QualifiedPost, QualifiedPre] = Nothing+              -- otherwise, expectedQual gets converted into a warning below (or is Nothing)+              | otherwise = expectedQual+        whenJust qualIdea $ \(qual, hint) -> do+          -- convert non-Nothing qualIdea into hlint's refactoring Idea+          let i' = noLoc $ (unLoc i){ ideclQualified = fromRight QualifiedPre qual+                                    , ideclImportList = fromMaybe ideclImportList expectedHiding }+              msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint+          Left $ warn msg (reLoc i) i' [] -checkFunctions :: String -> [Decl_] -> (Bool, Map.Map String RestrictItem) -> [Idea]-checkFunctions modu decls (def, mp) =-    [ (ideaMayBreak $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}+getRestrictItem :: Bool -> LocatedA ModuleName -> Map.Map String RestrictItem -> RestrictItem+getRestrictItem def ideclName =+  fromMaybe (RestrictItem mempty mempty mempty mempty [("","") | def] NoRestrictIdents Nothing)+    . lookupRestrictItem ideclName++lookupRestrictItem :: LocatedA ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem+lookupRestrictItem ideclName mp =+    let moduleName = moduleNameString $ unLoc ideclName+        exact = Map.lookup moduleName mp+        wildcard = nonEmpty+            . fmap snd+            . reverse -- the hope is less specific matches will end up last, but it's not guaranteed+            . filter (liftA2 (&&) (elem '*') (`wildcardMatch` moduleName) . fst)+            $ Map.toList mp+    in exact <> sconcat (sequence wildcard)++importListToIdents :: IE GhcPs -> [String]+importListToIdents =+  catMaybes .+  \case (IEVar _ n _)              -> [fromName n]+        (IEThingAbs _ n _)         -> [fromName n]+        (IEThingAll _ n _)         -> [fromName n]+        (IEThingWith _ n _ ns _)   -> fromName n : map fromName ns+        _                        -> []+  where+    fromName :: LIEWrappedName GhcPs -> Maybe String+    fromName wrapped =+      case unLoc wrapped of+        IEName    _ n -> fromId (unLoc n)+        IEPattern _ n -> ("pattern " ++) <$> fromId (unLoc n)+        IEType    _ n -> ("type " ++) <$> fromId (unLoc n)++    fromId :: IdP GhcPs -> Maybe String+    fromId (Unqual n) = Just $ occNameString n+    fromId (Qual _ n) = Just $ occNameString n+    fromId (Orig _ n) = Just $ occNameString n+    fromId (Exact _)  = Nothing++checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea]+checkFunctions scope modu decls (def, mp) =+    [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLoc x) (reLoc x) []){ideaDecl = [dname]}     | d <- decls-    , let dname = fromNamed d-    , x <- universeBi d :: [QName S]-    , not $ maybe def (within modu dname) $ Map.lookup (fromNamed x) mp+    , let dname = fromMaybe "" (declName d)+    , x <- universeBi d :: [LocatedN RdrName]+    , let xMods = possModules scope x+    , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction mp x xMods)+    , not $ within modu dname withins     ]++-- Returns Just iff there are rules for x, which are either unqualified, or qualified with a module that is+-- one of x's possible modules.+-- If there are multiple matching rules (e.g., there's both an unqualified version and a qualified version), their+-- withins and messages are concatenated with (<>).+findFunction+    :: Map.Map String RestrictFunction+    -> LocatedN RdrName+    -> [ModuleName]+    -> Maybe ([(String, String)], Maybe String)+findFunction restrictMap (rdrNameStr -> x) (map moduleNameString -> possMods) = do+    (RestrictFun mp) <- Map.lookup x restrictMap+    n <- NonEmpty.nonEmpty . Map.elems $ Map.filterWithKey (const . maybe True (`elem` possMods)) mp+    pure (sconcat n)
src/Hint/Smell.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-} -module Hint.Smell (-  smellModuleHint,-  smellHint-  ) where+module Hint.Smell (smellModuleHint,smellHint) where  {- <TEST> [{smell: { type: many arg functions, limit: 2 }}]@@ -79,20 +76,33 @@ </TEST> -} -import Hint.Type+import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn) import Config.Type++import Data.Generics.Uniplate.DataOnly import Data.List.Extra-import qualified Data.Map as Map+import Data.Map qualified as Map +import GHC.Utils.Outputable+import GHC.Types.Basic+import GHC.Hs+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable+ smellModuleHint :: [Setting] -> ModuHint-smellModuleHint settings scope m@(moduleImports -> imports) = case Map.lookup SmellManyImports (smells settings) of-  Just n | length imports >= n ->-           let span = foldl1 mergeSrcSpan $ srcInfoSpan . ann <$> imports-               displayImports = unlines $ f <$> imports-           in [rawIdea Warning "Many imports" span displayImports  Nothing [] [] ]-    where-      f = trimStart . prettyPrint-  _ -> []+smellModuleHint settings scope m =+  let (L _ mod) = ghcModule m+      imports = hsmodImports mod in+  case Map.lookup SmellManyImports (smells settings) of+    Just n | length imports >= n ->+             let span = foldl1 combineSrcSpans $ locA . getLoc <$> imports+                 displayImports = unlines $ f <$> imports+             in [rawIdea Config.Type.Warning "Many imports" span displayImports  Nothing [] [] ]+      where+        f :: LImportDecl GhcPs -> String+        f = trimStart . unsafePrettyPrint+    _ -> []  smellHint :: [Setting] -> DeclHint smellHint settings scope m d =@@ -102,46 +112,69 @@   where     sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings) -smellLongFunctions :: Decl_ -> Int -> [Idea]+smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea] smellLongFunctions d n = [ idea                          | (span, idea) <- declSpans d                          , spanLength span >= n                          ] -declSpans :: Decl_ -> [(SrcSpanInfo, Idea)]-declSpans (FunBind _ [Match _ _ _ rhs where_]) = rhsSpans rhs ++ whereSpans where_-declSpans f@(FunBind  l match)         = [(l, warn "Long function" f f [])] -- count where clauses-declSpans (PatBind _ _ rhs where_) = rhsSpans rhs ++ whereSpans where_-declSpans _                          = []+-- I've tried to be faithful to the original here but I'm doubtful+-- about it. I think I've replicated the behavior of the original but+-- is the original correctly honoring the intent? -whereSpans :: Maybe (Binds SrcSpanInfo) ->  [(SrcSpanInfo, Idea)]-whereSpans (Just (BDecls _ decls)) = concatMap declSpans decls-whereSpans _ = []+-- A function with with one alternative, one rhs and its 'where'+-- clause (perhaps we should be looping over alts and all guarded+-- right hand sides?)+declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]+declSpans+   (L _ (ValD _+     FunBind {fun_matches=MG {+                   mg_ext=FromSource+                 , mg_alts=(L _ [L _ Match {+                       m_ctxt=ctx+                     , m_grhss=GRHSs{grhssGRHSs=[locGrhs]+                                 , grhssLocalBinds=where_}}])}})) =+ -- The span of the right hand side and the spans of each binding in+ -- the where clause.+ rhsSpans ctx locGrhs ++ whereSpans where_+-- Any other kind of function.+declSpans f@(L l (ValD _ FunBind {})) = [(locA l, warn "Long function" (reLoc f) (reLoc f) [])]+declSpans _ = [] -rhsSpans :: Rhs SrcSpanInfo -> [(SrcSpanInfo, Idea)]-rhsSpans (UnGuardedRhs l RecConstr{}) = [] --- record constructors get a pass-rhsSpans r@(UnGuardedRhs l _) = [(l, warn "Long function" r r [])]-rhsSpans r@(GuardedRhss l _) = [(l, warn "Long function" r r [])]+-- The span of a guarded right hand side.+rhsSpans :: HsMatchContext (GenLocated SrcSpanAnnN RdrName) -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]+rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass+rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =+  [(locA l, rawIdea Config.Type.Warning "Long function" (locA l) (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] -spanLength :: SrcSpanInfo -> Int-spanLength (SrcSpanInfo span _) = srcSpanEndLine span - srcSpanStartLine span + 1+-- The spans of a 'where' clause are the spans of its bindings.+whereSpans :: HsLocalBinds GhcPs -> [(SrcSpan, Idea)]+whereSpans (HsValBinds _ (ValBinds _ bs _)) =+  concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) bs+whereSpans _ = [] -smellLongTypeLists :: Decl_ -> Int -> [Idea]-smellLongTypeLists d@(TypeSig _ _ t) n = warn "Long type list" d d [] <$ filter longTypeList (universe t)+spanLength :: SrcSpan -> Int+spanLength (RealSrcSpan span _) = srcSpanEndLine span - srcSpanStartLine span + 1+spanLength (UnhelpfulSpan _) = -1++smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]+smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+  warn "Long type list" (reLoc d) (reLoc d) [] <$ filter longTypeList (universe t)   where-    longTypeList (TyPromoted _ (PromotedList _ _ x)) = length x >= n+    longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n     longTypeList _ = False smellLongTypeLists _ _ = [] -smellManyArgFunctions :: Decl_ -> Int -> [Idea]-smellManyArgFunctions d@(TypeSig _ _ t) n = warn "Many arg function" d d [] <$  filter manyArgFunction (universe t)+smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]+smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (L _ (HsSig _ _ (L _ t))))))) n =+  warn "Many arg function" (reLoc d) (reLoc d) [] <$  filter manyArgFunction (universe t)   where-    manyArgFunction x = countFunctionArgs x >= n+    manyArgFunction t = countFunctionArgs t >= n smellManyArgFunctions _ _ = [] -countFunctionArgs :: Type l -> Int-countFunctionArgs (TyFun _ _ b) = 1 + countFunctionArgs b-countFunctionArgs (TyParen _ t) = countFunctionArgs t+countFunctionArgs :: HsType GhcPs -> Int+countFunctionArgs (HsFunTy _ _ _ t) = 1 + countFunctionArgs (unLoc t)+countFunctionArgs (HsParTy _ t) = countFunctionArgs (unLoc t) countFunctionArgs _ = 0  smells :: [Setting] -> Map.Map SmellType Int
src/Hint/Type.hs view
@@ -6,33 +6,33 @@  import Data.Semigroup import Config.Type-import HSE.All  as Export+import GHC.All  as Export import Idea     as Export import Prelude import Refact   as Export-+import GHC.Hs.Extension+import GHC.Hs.Decls+import GHC.Util.Scope -type DeclHint = Scope -> Module_ -> Decl_ -> [Idea]-type ModuHint = Scope -> Module_          -> [Idea]-type CrossHint = [(Scope, Module_)] -> [Idea]+type DeclHint = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]+type ModuHint = Scope -> ModuleEx -> [Idea]+type CrossHint = [(Scope, ModuleEx)] -> [Idea]  -- | Functions to generate hints, combined using the 'Monoid' instance.-data Hint {- PUBLIC -} = Hint-    {hintModules :: [Setting] -> [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.-    ,hintModule :: [Setting] -> Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.-    ,hintDecl :: [Setting] -> Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]+data Hint = Hint+    { hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.+    , hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.+    , hintDecl :: [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]         -- ^ Given a declaration (with a module and scope) generate some 'Idea's.         --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.-    ,hintComment :: [Setting] -> Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.     }  instance Semigroup Hint where-    Hint x1 x2 x3 x4 <> Hint y1 y2 y3 y4 = Hint+    Hint x1 x2 x3 <> Hint y1 y2 y3 = Hint         (\a b -> x1 a b ++ y1 a b)         (\a b c -> x2 a b c ++ y2 a b c)         (\a b c d -> x3 a b c d ++ y3 a b c d)-        (\a b -> x4 a b ++ y4 a b)  instance Monoid Hint where-    mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ -> [])+    mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> [])     mappend = (<>)
src/Hint/Unsafe.hs view
@@ -3,51 +3,88 @@     Find things that are unsafe  <TEST>-{-# NOINLINE slaves #-}; slaves = unsafePerformIO newIO-slaves = unsafePerformIO Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO Multimap.newIO-slaves = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO $ f y where foo = 1-slaves v = unsafePerformIO $ Multimap.newIO where foo = 1-slaves v = x where x = unsafePerformIO $ Multimap.newIO-slaves = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE slaves #-} ; slaves = x where x = unsafePerformIO $ Multimap.newIO-slaves = unsafePerformIO . bar-slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x-slaves = unsafePerformIO . baz $ x -- {-# NOINLINE slaves #-} ; slaves = unsafePerformIO . baz $ x+{-# NOINLINE entries #-}; entries = unsafePerformIO newIO+entries = unsafePerformIO Multimap.newIO -- {-# NOINLINE entries #-} ; entries = unsafePerformIO Multimap.newIO+entries = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE entries #-} ; entries = unsafePerformIO $ f y where foo = 1+entries v = unsafePerformIO $ Multimap.newIO where foo = 1+entries v = x where x = unsafePerformIO $ Multimap.newIO+entries = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE entries #-} ; entries = x where x = unsafePerformIO $ Multimap.newIO+entries = unsafePerformIO . bar+entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x+entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x </TEST> -}   module Hint.Unsafe(unsafeHint) where -import Hint.Type-import Data.Char-import Refact.Types+import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSSA)+import Data.List.Extra+import Refact.Types hiding(Match)+import Data.Generics.Uniplate.DataOnly +import GHC.Hs+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Data.FastString+import GHC.Types.Basic+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +-- The conditions on which to fire this hint are subtle. We are+-- interested exclusively in application constants involving+-- 'unsafePerformIO'. For example,+-- @+--   f = \x -> unsafePerformIO x+-- @+-- is not such a declaration (the right hand side is a lambda, not an+-- application) whereas,+-- @+--   f = g where g = unsafePerformIO Multimap.newIO+-- @+-- is. We advise that such constants should have a @NOINLINE@ pragma. unsafeHint :: DeclHint-unsafeHint _ m = \d ->-        [ rawIdea Warning "Missing NOINLINE pragma" (srcInfoSpan $ ann d)-            (prettyPrint d)-            (Just $ dropWhile isSpace (prettyPrint $ gen x) ++ "\n" ++ prettyPrint d)-            [] [InsertComment (toSS d) (prettyPrint $ gen x)]-        | d@(PatBind _ (PVar _ x) _ _) <- [d]-        , isUnsafeDecl d, x `notElem_` noinline]-    where-        gen x = InlineSig an False Nothing $ UnQual an x-        noinline = [q | InlineSig _ False Nothing (UnQual _ q) <- moduleDecls m]+unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->+  [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" (locA loc)+         (unsafePrettyPrint d)+         (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)+         [] [InsertComment (toSSA ld) (unsafePrettyPrint $ gen x)]+     -- 'x' does not declare a new function.+     | d@(ValD _+           FunBind {fun_id=L _ (Unqual x)+                      , fun_matches=MG{mg_ext=FromSource,mg_alts=L _ [L _ Match {m_pats=L _ []}]}}) <- [d]+     -- 'x' is a synonym for an application involving 'unsafePerformIO'+     , isUnsafeDecl d+     -- 'x' is not marked 'NOINLINE'.+     , x `notElem` noinline]+  where+    noInline :: FastString+    noInline = fsLit $ '{' : '-' : '#' : " NOINLINE" -isUnsafeDecl :: Decl_ -> Bool-isUnsafeDecl (PatBind _ _ rhs bind) =-    any isUnsafeApp (childrenBi rhs) || any isUnsafeDecl (childrenBi bind)+    gen :: OccName -> LHsDecl GhcPs+    gen x = noLocA $+      SigD noExtField (InlineSig noAnn (noLocA (mkRdrUnqual x))+                      (InlinePragma (SourceText noInline) (NoInline (SourceText noInline)) Nothing NeverActive FunLike))+    noinline :: [OccName]+    noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))+                                                (InlinePragma _ (NoInline (SourceText noInline)) Nothing NeverActive FunLike))+        ) <- hsmodDecls m]++isUnsafeDecl :: HsDecl GhcPs -> Bool+isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_ext=FromSource,mg_alts=L _ alts}}) =+  any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False --- Am I equivalent to @unsafePerformIO x@-isUnsafeApp :: Exp_ -> Bool-isUnsafeApp (InfixApp _ x d _) | isDol d = isUnsafeFun x-isUnsafeApp (App _ x _) = isUnsafeFun x+-- Am I equivalent to @unsafePerformIO x@?+isUnsafeApp :: HsExpr GhcPs -> Bool+isUnsafeApp (OpApp _ (L _ l) op _ ) | isDol op = isUnsafeFun l+isUnsafeApp (HsApp _ (L _ x) _) = isUnsafeFun x isUnsafeApp _ = False --- Am I equivalent to @unsafePerformIO . x@-isUnsafeFun :: Exp_ -> Bool-isUnsafeFun (Var _ x) | x ~= "unsafePerformIO" = True-isUnsafeFun (InfixApp _ x d _) | isDot d = isUnsafeFun x+-- Am I equivalent to @unsafePerformIO . x@?+isUnsafeFun :: HsExpr GhcPs -> Bool+isUnsafeFun (HsVar _ (L _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True+isUnsafeFun (OpApp _ (L _ l) op _) | isDot op = isUnsafeFun l isUnsafeFun _ = False
− src/Hint/Util.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}--module Hint.Util(niceLambda, simplifyExp, niceLambdaR) where--import HSE.All-import Data.List.Extra-import Refact.Types-import Refact-import qualified Refact.Types as R (SrcSpan)--niceLambda :: [String] -> Exp_ -> Exp_-niceLambda ss e = fst (niceLambdaR ss e)----- | Generate a lambda, but prettier (if possible).---   Generally no lambda is good, but removing just some arguments isn't so useful.-niceLambdaR :: [String] -> Exp_ -> (Exp_, R.SrcSpan -> [Refactoring R.SrcSpan])---- \xs -> (e) ==> \xs -> e-niceLambdaR xs (Paren l x) = niceLambdaR xs x---- \xs -> \v vs -> e ==> \xs v -> \vs -> e--- \xs -> \ -> e ==> \xs -> e-niceLambdaR xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambdaR (xs++[v]) (Lambda an vs x)-niceLambdaR xs (Lambda _ [] x) = niceLambdaR xs x---- \ -> e ==> e-niceLambdaR [] x = (x, const [])---- \vs v -> e $ v ==> \vs -> e-niceLambdaR (unsnoc -> Just (vs, v)) (InfixApp _ e (isDol -> True) (view -> Var_ v2))-    | v == v2, vars e `disjoint` [v]-    = niceLambdaR vs e---- \xs -> e xs ==> e-niceLambdaR xs (fromAppsWithLoc -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 =-    (apps e2, \s -> [Replace Expr s [("x", pos)] "x"])-    where (e',xs') = splitAt (length e - length xs) e-          (e2, xs2) = (map fst e', map fst xs')-          pos      = toRefactSrcSpan . srcInfoSpan $ snd (last e')---- \x y -> x + y ==> (+)-niceLambdaR [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1))-    | x == x1, y == y1, vars op `disjoint` [x,y] = (op, \s -> [Replace Expr s [] (prettyPrint op)])---- \x -> x + a ==> (+ a) [heuristic, ab must be a single lexeme, or gets too complex]-niceLambdaR [x] (view -> App2 (expOp -> Just op) xx a)-    | isLexeme a, view xx == Var_ x, x `notElem` vars a, allowRightSection (fromNamed op) =-      let e = rebracket1 $ RightSection an op a-      in (e, \s -> [Replace Expr s [] (prettyPrint e)])---- \x -> a + x ==> (a +) [heuristic, a must be a single lexeme, or gets too complex]-niceLambdaR [x] (view -> App2 (expOp -> Just op) a xx)-    | isLexeme a, view xx == Var_ x, x `notElem` vars a =-      let e = rebracket1 $ LeftSection an a op-      in (e, \s -> [Replace Expr s [] (prettyPrint e)])---- \x y -> f y x = flip f-niceLambdaR [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))-    | x == x1, y == y1, vars op `disjoint` [x,y] = (gen op, \s -> [Replace Expr s [("x", toSS op)] (prettyPrint $ gen (toNamed "x"))])-    where-      gen = App an (toNamed "flip")---- \x -> f (b x) ==> f . b--- \x -> f $ b x ==> f . b-niceLambdaR [x] y | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])-    where-        -- factor the expression with respect to x-        factor y@(App _ ini lst) | view lst == Var_ x = Just (ini, [ann ini])-        factor y@(App _ ini lst) | Just (z, ss) <- factor lst = let r = niceDotApp ini z-                                                           in if r == z then Just (r, ss)-                                                                        else Just (r, ann ini : ss)-        factor (InfixApp _ y op (factor -> Just (z, ss))) | isDol op = let r = niceDotApp y z-                                                                 in if r == z then Just (r, ss)-                                                                              else Just (r, ann y : ss)-        factor (Paren _ y@App{}) = factor y-        factor _ = Nothing-        mkRefact :: [S] -> R.SrcSpan -> Refactoring R.SrcSpan-        mkRefact subts s =-          let tempSubts = zipWith (\a b -> ([a], toRefactSrcSpan $ srcInfoSpan b)) ['a' .. 'z'] subts-              template = dotApps (map (toNamed . fst) tempSubts)-          in Replace Expr s tempSubts (prettyPrint template)----- \x -> (x +) ==> (+)--- Section handling is not yet supported for refactoring-niceLambdaR [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 =-  let e = opExp op-  in (e, \s -> [Replace Expr s [] (prettyPrint e)])---- base case-niceLambdaR ps x = (Lambda an (map toNamed ps) x, const [])------ ($) . b ==> b-niceDotApp :: Exp_ -> Exp_ -> Exp_-niceDotApp a b | a ~= "$" = b-               | otherwise = dotApp a b------ | Convert expressions which have redundant junk in them away.---   Mainly so that later stages can match on fewer alternatives.-simplifyExp :: Exp_ -> Exp_-simplifyExp (InfixApp _ x dol y) | isDol dol = App an x (paren y)-simplifyExp (Let _ (BDecls _ [PatBind _ (view -> PVar_ x) (UnGuardedRhs _ y) Nothing]) z)-    | x `notElem` vars y && length [() | UnQual _ a <- universeS z, prettyPrint a == x] <= 1 = transform f z-    where f (view -> Var_ x') | x == x' = paren y-          f x = x-simplifyExp x = x
src/HsColour.hs view
@@ -3,24 +3,22 @@  #ifdef GPL_SCARES_ME -hsColourConsole :: IO (String -> String)-hsColourConsole = return id+hsColourConsole :: String -> String+hsColourConsole = id  hsColourHTML :: String -> String hsColourHTML = id  #else -import Data.Functor import Prelude  import Language.Haskell.HsColour.TTY as TTY import Language.Haskell.HsColour.Colourise import Language.Haskell.HsColour.CSS as CSS --hsColourConsole :: IO (String -> String)-hsColourConsole = TTY.hscolour <$> readColourPrefs+hsColourConsole :: String -> String+hsColourConsole = TTY.hscolour defaultColourPrefs  hsColourHTML :: String -> String hsColourHTML = CSS.hscolour False 1
src/Idea.hs view
@@ -1,23 +1,26 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-}  module Idea(     Idea(..),-    rawIdea, idea, suggest, warn, ignore,-    rawIdeaN, suggestN, ignoreN,-    showIdeasJson, showANSI,+    rawIdea, idea, suggest, suggestRemove, ideaRemove, warn, ignore,+    rawIdeaN, suggestN, ignoreNoSuggestion,+    showIdeasJson, showIdeaANSI,     Note(..), showNotes,-    Severity(..)+    Severity(..),     ) where -import Data.Functor import Data.List.Extra-import HSE.All import Config.Type import HsColour import Refact.Types hiding (SrcSpan)-import qualified Refact.Types as R+import Refact.Types qualified as R import Prelude+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Util +import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable  -- | An idea suggest by a 'Hint'. data Idea = Idea@@ -31,10 +34,10 @@     ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.     ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea     }-    deriving (Eq,Ord)+    deriving Eq  -- I don't use aeson here for 2 reasons:--- 1) Aeson doesn't esape unicode characters, and I want to (allows me to ignore encoding)+-- 1) Aeson doesn't escape unicode characters, and I want to (allows me to ignore encoding) -- 2) I want to control the format so it's slightly human readable as well showIdeaJson :: Idea -> String showIdeaJson idea@Idea{ideaSpan=srcSpan@SrcSpan{..}, ..} = dict@@ -43,9 +46,9 @@     ,("severity", str $ show ideaSeverity)     ,("hint", str ideaHint)     ,("file", str srcSpanFilename)-    ,("startLine", show srcSpanStartLine)+    ,("startLine", show srcSpanStartLine')     ,("startColumn", show srcSpanStartColumn)-    ,("endLine", show srcSpanEndLine)+    ,("endLine", show srcSpanEndLine')     ,("endColumn", show srcSpanEndColumn)     ,("from", str ideaFrom)     ,("to", maybe "null" str ideaTo)@@ -57,6 +60,7 @@     dict xs = "{" ++ intercalate "," [show k ++ ":" ++ v | (k,v) <- xs] ++ "}"     list xs = "[" ++ intercalate "," xs ++ "]" +-- | Show a list of 'Idea' values as a JSON string. showIdeasJson :: [Idea] -> String showIdeasJson ideas = "[" ++ intercalate "\n," (map showIdeaJson ideas) ++ "]" @@ -64,12 +68,13 @@     show = showEx id  -showANSI :: IO (Idea -> String)-showANSI = showEx <$> hsColourConsole+-- | Show an 'Idea' with ANSI color codes to give syntax coloring to the Haskell code.+showIdeaANSI :: Idea -> String+showIdeaANSI = showEx hsColourConsole  showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $-    [showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] +++    [showSrcSpan ideaSpan ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++     f "Found" (Just ideaFrom) ++ f "Perhaps" ideaTo ++     ["Note: " ++ n | let n = showNotes ideaNote, n /= ""]     where@@ -79,17 +84,44 @@             where xs = lines $ tt x  +rawIdea :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea rawIdea = Idea [] []++rawIdeaN :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea rawIdeaN a b c d e f = Idea [] [] a b c d e f [] -idea severity hint from to = rawIdea severity hint (srcInfoSpan $ ann from) (f from) (Just $ f to) []-    where f = trimStart . prettyPrint+idea :: (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable b) =>+         Severity -> String -> Located a -> Located b -> [Refactoring R.SrcSpan] -> Idea+idea severity hint from to =+  rawIdea severity hint (getLoc from) (unsafePrettyPrint from) (Just $ unsafePrettyPrint to) [] +-- Construct an Idea that suggests "Perhaps you should remove it."+ideaRemove :: Severity -> String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea+ideaRemove severity hint span from = rawIdea severity hint span from (Just "") []++suggest :: (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable b) =>+            String -> Located a -> Located b -> [Refactoring R.SrcSpan] -> Idea suggest = idea Suggestion++suggestRemove :: String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea+suggestRemove = ideaRemove Suggestion++warn :: (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable b) =>+         String -> Located a -> Located b -> [Refactoring R.SrcSpan] -> Idea warn = idea Warning++ignoreNoSuggestion :: (GHC.Utils.Outputable.Outputable a)+                    => String -> Located a -> Idea+ignoreNoSuggestion hint x = rawIdeaN Ignore hint (getLoc x) (unsafePrettyPrint x) Nothing []++ignore :: (GHC.Utils.Outputable.Outputable a) =>+           String -> Located a -> Located a -> [Refactoring R.SrcSpan] -> Idea ignore = idea Ignore +ideaN :: (GHC.Utils.Outputable.Outputable a) =>+          Severity -> String -> Located a -> Located a -> Idea ideaN severity hint from to = idea severity hint from to [] +suggestN :: (GHC.Utils.Outputable.Outputable a) =>+             String -> Located a -> Located a -> Idea suggestN = ideaN Suggestion-ignoreN = ideaN Ignore
src/Language/Haskell/HLint.hs view
@@ -1,43 +1,155 @@-{-|-/WARNING: This module represents the old version of the HLint API./-/It will be deleted in favour of "Language.Haskell.HLint3" in the next major version./--This module provides a library interface to HLint, strongly modelled on the command line interface.--}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE PatternGuards, RecordWildCards #-} -module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where+-- |  This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process+--   and collect the results see 'hlint'.+--+--   If you want to approximate the @hlint@ experience with+--   a more structured API try:+--+-- @+-- (flags, classify, hint) <- 'autoSettings'+-- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing+-- print $ 'applyHints' classify hint [m]+-- @+module Language.Haskell.HLint(+    -- * Generate hints+    hlint, applyHints,+    -- * Idea data type+    Idea(..), Severity(..), Note(..), unpackSrcSpan, showIdeaANSI,+    -- * Settings+    Classify(..),+    getHLintDataDir, autoSettings, argsSettings,+    findSettings, readSettingsFile,+    -- * Hints+    Hint,+    -- * Modules+    ModuleEx, parseModuleEx, createModuleEx, createModuleExWithFixities, ParseError(..),+    -- * Parse flags+    defaultParseFlags,+    ParseFlags(..), CppFlags(..), FixityInfo,+    parseFlagsAddFixities,+    ) where -import qualified HLint import Config.Type+import Config.Read import Idea-import HSE.All+import Apply qualified as H+import HLint+import Fixity+import GHC.Data.FastString ( unpackFS )+import GHC.All+import Hint.All hiding (resolveHints)+import Hint.All qualified as H+import GHC.Types.SrcLoc+import CmdLine+import Paths_hlint +import Data.List.Extra+import Data.Maybe+import System.FilePath+import Data.Functor+import Prelude+import Hint.Restrict qualified as Restrict --- | This function takes a list of command line arguments, and returns the given suggestions.---   To see a list of arguments type @hlint --help@ at the console.---   This function writes to the stdout/stderr streams, unless @--quiet@ is specified.++-- | Get the Cabal configured data directory of HLint.+getHLintDataDir :: IO FilePath+getHLintDataDir = getDataDir+++-- | The function produces a tuple containing 'ParseFlags' (for 'parseModuleEx'),+--   and 'Classify' and 'Hint' for 'applyHints'.+--   It approximates the normal HLint configuration steps, roughly: -----   As an example:+-- 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files. ----- > do hints <- hlint ["src", "--ignore=Use map","--quiet"]--- >    when (length hints > 3) $ error "Too many hints!"-hlint :: [String] -> IO [Suggestion]-hlint = fmap (map Suggestion_) . HLint.hlint+-- 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'.+--+--   If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs,+--   loading hints from a database) you are expected to copy and paste this function, then change it to your needs.+autoSettings :: IO (ParseFlags, [Classify], Hint)+autoSettings = do+    (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing+    pure (parseFlagsAddFixities fixities defaultParseFlags, classify, hints)  +-- | A version of 'autoSettings' which respects some of the arguments supported by HLint.+--   If arguments unrecognised by HLint are used it will result in an error.+--   Arguments which have no representation in the return type are silently ignored.+argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint)+argsSettings args = do+    cmd@CmdMain{..} <- getCmd args+    -- FIXME: One thing that could be supported (but isn't) is 'cmdGivenHints'+    (_,settings) <- readAllSettings args cmd+    let (fixities, classify, hints) = splitSettings settings+    let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $+                defaultParseFlags{cppFlags = cmdCpp cmd}+    let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]+    pure (flags, classify ++ ignore, hints) --- | A suggestion - the @Show@ instance is of particular use.-newtype Suggestion = Suggestion_ {fromSuggestion :: Idea}-                     deriving (Eq,Ord) -instance Show Suggestion where-    show = show . fromSuggestion+-- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name+--   (e.g. @HLint.Default@), find the settings file associated with it, returning the+--   name of the file, and (optionally) the contents.+--+--   This function looks for all settings files starting with @HLint.@ in the directory+--   argument, and all other files relative to the current directory.+readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String)+readSettingsFile dir x+    | takeExtension x `elem` [".yml",".yaml"] = do+        dir <- maybe getHLintDataDir pure dir+        pure (dir </> x, Nothing)+    | Just x <- "HLint." `stripPrefix` x = do+        dir <- maybe getHLintDataDir pure dir+        pure (dir </> x <.> "hs", Nothing)+    | otherwise = pure (x <.> "hs", Nothing) --- | From a suggestion, extract the file location it refers to.-suggestionLocation :: Suggestion -> SrcLoc-suggestionLocation = getPointLoc . ideaSpan . fromSuggestion +-- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from+--   (defaults to @hlint.yaml@) find the information from all settings files.+findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([FixityInfo], [Classify], Hint)+findSettings load start = do+    (file,contents) <- load $ fromMaybe "hlint.yaml" start+    splitSettings <$> readFilesConfig [(file,contents)] --- | From a suggestion, determine how severe it is.-suggestionSeverity :: Suggestion -> Severity-suggestionSeverity = ideaSeverity . fromSuggestion+-- | Split a list of 'Setting' for separate use in parsing and hint resolution+splitSettings :: [Setting] -> ([FixityInfo], [Classify], Hint)+splitSettings xs =+    ([x | Infix x <- xs]+    ,[x | SettingClassify x <- xs]+    ,H.resolveHints ([Right x | SettingMatchExp x <- xs] ++ map Left enumerate)+    <> mempty { hintModule = Restrict.restrictHint . (xs++)}+    )+++-- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.+--   The 'Idea' values will be ordered within a file.+--+--   Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list.+--   When given multiple modules at once this function attempts to find hints between modules,+--   which is slower and often pointless (by default HLint passes modules singularly, using+--   @--cross@ to pass all modules together).+applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]+applyHints = H.applyHints++-- | Snippet from the documentation, if this changes, update the documentation+_docs :: IO ()+_docs = do+    (flags, classify, hint) <- autoSettings+    Right m <- parseModuleEx flags "MyFile.hs" Nothing+    print $ applyHints classify hint [m]++-- | Unpack a 'SrcSpan' value. Useful to allow using the 'Idea' information without+--   adding a dependency on @ghc@ or @ghc-lib-parser@. Unpacking gives:+--+-- > (filename, (startLine, startCol), (endLine, endCol))+--+--   Following the GHC API, end column is the column /after/ the end of the error.+--   Lines and columns are 1-based. Returns 'Nothing' if there is no helpful location information.+unpackSrcSpan :: SrcSpan -> Maybe (FilePath, (Int, Int), (Int, Int))+unpackSrcSpan (RealSrcSpan x _) = Just+    (unpackFS $ srcSpanFile x+    ,(srcSpanStartLine x, srcSpanStartCol x)+    ,(srcSpanEndLine x, srcSpanEndCol x))+unpackSrcSpan _ = Nothing
− src/Language/Haskell/HLint3.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-}---- | /WARNING: This module represents a previous version of the HLint API./---   /Please use "Language.Haskell.HLint4" instead./-module Language.Haskell.HLint3(-    hlint, applyHints,-    -- * Idea data type-    Idea(..), Severity(..), Note(..),-    -- * Settings-    Classify(..),-    getHLintDataDir, autoSettings, argsSettings,-    findSettings, readSettingsFile,-    -- * Hints-    HintBuiltin(..), HintRule(..),-    Hint(..), resolveHints,-    -- * Scopes-    Scope, scopeCreate, scopeMatch, scopeMove,-    -- * Haskell-src-exts-    parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)-    ) where--import Config.Type-import Config.Read-import Idea-import Apply-import HLint-import HSE.All hiding (parseModuleEx)-import qualified HSE.All as H-import Hint.All-import CmdLine-import Paths_hlint--import Data.List.Extra-import Data.Maybe-import System.FilePath-import Data.Functor-import Prelude----- | Get the Cabal configured data directory of HLint.-getHLintDataDir :: IO FilePath-getHLintDataDir = getDataDir----- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'),---   and 'Classify' and 'Hint' for 'applyHints'.---   It approximates the normal HLint configuration steps, roughly:------ 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files.------ 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'.------   If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs,---   loading hints from a database) you are expected to copy and paste this function, then change it to your needs.-autoSettings :: IO (ParseFlags, [Classify], Hint)-autoSettings = do-    (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing-    return (parseFlagsAddFixities fixities defaultParseFlags, classify, resolveHints hints)----- | A version of 'autoSettings' which respects some of the arguments supported by HLint.---   If arguments unrecognised by HLint are used it will result in an error.---   Arguments which have no representation in the return type are silently ignored.-argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint)-argsSettings args = do-    cmd <- getCmd args-    case cmd of-        CmdMain{..} -> do-            -- FIXME: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'.-            (_,settings) <- readAllSettings args cmd-            let (fixities, classify, hints) = splitSettings settings-            let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $-                        defaultParseFlags{cppFlags = cmdCpp cmd}-            let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]-            return (flags, classify ++ ignore, resolveHints hints)-        _ -> error "Can only invoke autoSettingsArgs with the root process"----- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name---   (e.g. @HLint.Default@), find the settings file associated with it, returning the---   name of the file, and (optionally) the contents.------   This function looks for all settings files starting with @HLint.@ in the directory---   argument, and all other files relative to the current directory.-readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String)-readSettingsFile dir x-    | takeExtension x `elem` [".yml",".yaml"] = do-        dir <- maybe getHLintDataDir return dir-        return (dir </> x, Nothing)-    | Just x <- "HLint." `stripPrefix` x = do-        dir <- maybe getHLintDataDir return dir-        return (dir </> x <.> "hs", Nothing)-    | otherwise = return (x <.> "hs", Nothing)----- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from---   (defaults to @hlint.yaml@) find the information from all settings files.-findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([Fixity], [Classify], [Either HintBuiltin HintRule])-findSettings load start = do-    (file,contents) <- load $ fromMaybe "hlint.yaml" start-    splitSettings <$> readFilesConfig [(file,contents)]---- | Split a list of 'Setting' for separate use in parsing and hint resolution-splitSettings :: [Setting] -> ([Fixity], [Classify], [Either HintBuiltin HintRule])-splitSettings xs =-    ([x | Infix x <- xs]-    ,[x | SettingClassify x <- xs]-    ,[Right x | SettingMatchExp x <- xs] ++ map Left [minBound..maxBound])----- | 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.-parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))-parseModuleEx flags file str = fmap pm_hsext <$> H.parseModuleEx flags file str----- | Snippet from the documentation, if this changes, update the documentation-_docs :: IO ()-_docs = do-    (flags, classify, hint) <- autoSettings-    Right (m, c) <- parseModuleEx flags "MyFile.hs" Nothing-    print $ applyHints classify hint [(m, c)]
− src/Language/Haskell/HLint4.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-}---- | /WARNING: This module represents the evolving version of the HLint API./---   /It will be renamed to drop the "4" in the next major version./------   This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process---   and collect the results see 'hlint'. If you want to approximate the @hlint@ experience with---   a more structured API try:------ @--- (flags, classify, hint) <- 'autoSettings'--- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing--- print $ 'applyHints' classify hint [m]--- @-module Language.Haskell.HLint4(-    hlint, applyHints,-    -- * Idea data type-    Idea(..), Severity(..), Note(..),-    -- * Settings-    Classify(..),-    getHLintDataDir, autoSettings, argsSettings,-    findSettings, readSettingsFile,-    -- * Hints-    Hint, resolveHints,-    -- * Parse files-    ModuleEx, parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)-    ) where--import Config.Type-import Config.Read-import Idea-import qualified Apply as H-import HLint-import HSE.All-import Hint.All hiding (resolveHints)-import qualified Hint.All as H-import CmdLine-import Paths_hlint--import Data.List.Extra-import Data.Maybe-import System.FilePath-import Data.Functor-import Prelude----- | Get the Cabal configured data directory of HLint.-getHLintDataDir :: IO FilePath-getHLintDataDir = getDataDir----- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'),---   and 'Classify' and 'Hint' for 'applyHints'.---   It approximates the normal HLint configuration steps, roughly:------ 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files.------ 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'.------   If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs,---   loading hints from a database) you are expected to copy and paste this function, then change it to your needs.-autoSettings :: IO (ParseFlags, [Classify], Hint)-autoSettings = do-    (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing-    return (parseFlagsAddFixities fixities defaultParseFlags, classify, hints)----- | The identity function. In previous versions of HLint this function was useful. Now, it isn't.-resolveHints :: Hint -> Hint-resolveHints = id---- | A version of 'autoSettings' which respects some of the arguments supported by HLint.---   If arguments unrecognised by HLint are used it will result in an error.---   Arguments which have no representation in the return type are silently ignored.-argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint)-argsSettings args = do-    cmd <- getCmd args-    case cmd of-        CmdMain{..} -> do-            -- FIXME: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'.-            (_,settings) <- readAllSettings args cmd-            let (fixities, classify, hints) = splitSettings settings-            let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $-                        defaultParseFlags{cppFlags = cmdCpp cmd}-            let ignore = [Classify Ignore x "" "" | x <- cmdIgnore]-            return (flags, classify ++ ignore, hints)-        _ -> error "Can only invoke autoSettingsArgs with the root process"----- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name---   (e.g. @HLint.Default@), find the settings file associated with it, returning the---   name of the file, and (optionally) the contents.------   This function looks for all settings files starting with @HLint.@ in the directory---   argument, and all other files relative to the current directory.-readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String)-readSettingsFile dir x-    | takeExtension x `elem` [".yml",".yaml"] = do-        dir <- maybe getHLintDataDir return dir-        return (dir </> x, Nothing)-    | Just x <- "HLint." `stripPrefix` x = do-        dir <- maybe getHLintDataDir return dir-        return (dir </> x <.> "hs", Nothing)-    | otherwise = return (x <.> "hs", Nothing)----- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from---   (defaults to @hlint.yaml@) find the information from all settings files.-findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([Fixity], [Classify], Hint)-findSettings load start = do-    (file,contents) <- load $ fromMaybe "hlint.yaml" start-    splitSettings <$> readFilesConfig [(file,contents)]---- | Split a list of 'Setting' for separate use in parsing and hint resolution-splitSettings :: [Setting] -> ([Fixity], [Classify], Hint)-splitSettings xs =-    ([x | Infix x <- xs]-    ,[x | SettingClassify x <- xs]-    ,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left [minBound..maxBound])----- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.---   The 'Idea' values will be ordered within a file.------   Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list.---   When given multiple modules at once this function attempts to find hints between modules,---   which is slower and often pointless (by default HLint passes modules singularly, using---   @--cross@ to pass all modules together).-applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]-applyHints a b = H.applyHints a b . map pm_hsext----- | Snippet from the documentation, if this changes, update the documentation-_docs :: IO ()-_docs = do-    (flags, classify, hint) <- autoSettings-    Right m <- parseModuleEx flags "MyFile.hs" Nothing-    print $ applyHints classify hint [m]
src/Main.hs view
@@ -1,7 +1,7 @@  module Main(main) where -import Language.Haskell.HLint3+import Language.Haskell.HLint import Control.Monad import System.Environment import System.Exit
src/Parallel.hs view
@@ -3,7 +3,7 @@  import Control.Parallel.Strategies parallel :: [IO [a]] -> IO [[a]]-parallel = return . withStrategy (parList $ seqList r0) . map unsafePerformIO+parallel = pure . withStrategy (parList $ seqList r0) . map unsafePerformIO  However, this version performs about 10% slower with 2 processors in GHC 6.12.1 -}@@ -21,11 +21,11 @@   parallel1 :: [IO a] -> IO [a]-parallel1 [] = return []+parallel1 [] = pure [] parallel1 (x:xs) = do     x2 <- x     xs2 <- unsafeInterleaveIO $ parallel1 xs-    return $ x2:xs2+    pure $ x2:xs2   parallelN :: Int -> [IO a] -> IO [a]@@ -40,7 +40,7 @@         f chan = do             v <- readChan chan             case v of-                Nothing -> return ()+                Nothing -> pure ()                 Just (m,x) -> do                     putMVar m =<< try x                     f chan
src/Refact.hs view
@@ -1,13 +1,88 @@-module Refact(toRefactSrcSpan, toSS) where+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-} -import qualified Refact.Types as R-import HSE.All+module Refact+    ( substVars+    , toRefactSrcSpan+    , toSS, toSSA, toSSAnc+    , checkRefactor, refactorPath, runRefactoring+    ) where -toRefactSrcSpan :: SrcSpan -> R.SrcSpan-toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss)-                               (srcSpanStartColumn ss)-                               (srcSpanEndLine ss)-                               (srcSpanEndColumn ss)+import Control.Exception.Extra+import Control.Monad+import Data.List.NonEmpty qualified as NE+import Data.Maybe+import Data.Version.Extra+import GHC.LanguageExtensions.Type+import System.Console.CmdArgs.Verbosity+import System.Directory.Extra+import System.Exit+import System.IO.Extra+import System.Process.Extra+import Refact.Types qualified as R -toSS :: Annotated a => a S -> R.SrcSpan-toSS = toRefactSrcSpan . srcInfoSpan . ann+import GHC.Types.SrcLoc qualified as GHC+import GHC.Parser.Annotation qualified as GHC++import GHC.Util.SrcLoc (getAncLoc)++substVars :: [String]+substVars = [letter : number | number <- "" : map show [0..], letter <- ['a'..'z']]++toRefactSrcSpan :: GHC.SrcSpan -> R.SrcSpan+toRefactSrcSpan = \case+    GHC.RealSrcSpan span _ ->+        R.SrcSpan (GHC.srcSpanStartLine span)+                  (GHC.srcSpanStartCol span)+                  (GHC.srcSpanEndLine span)+                  (GHC.srcSpanEndCol span)+    GHC.UnhelpfulSpan _ ->+        R.SrcSpan (-1) (-1) (-1) (-1)++-- | Don't crash in case ghc gives us a \"fake\" span,+-- opting instead to show @-1 -1 -1 -1@ coordinates.+toSS :: GHC.Located a -> R.SrcSpan+toSS = toRefactSrcSpan . GHC.getLoc++toSSA :: GHC.GenLocated (GHC.EpAnn a) e -> R.SrcSpan+toSSA = toRefactSrcSpan . GHC.getLocA++toSSAnc :: GHC.GenLocated GHC.NoCommentsLocation e -> R.SrcSpan+toSSAnc = toRefactSrcSpan . getAncLoc++checkRefactor :: Maybe FilePath -> IO FilePath+checkRefactor = refactorPath >=> either errorIO pure++refactorPath :: Maybe FilePath -> IO (Either String FilePath)+refactorPath rpath = do+    let excPath = fromMaybe "refactor" rpath+    mexc <- findExecutable excPath+    case mexc of+        Just exc -> do+            ver <- readVersion . NE.tail . NE.fromList <$> readProcess exc ["--version"] ""+            pure $ if ver >= minRefactorVersion+                       then Right exc+                       else Left $ "Your version of refactor is too old, please install apply-refact "+                                ++ showVersion minRefactorVersion+                                ++ " or later. Apply-refact can be installed from Cabal or Stack."+        Nothing -> pure $ Left $ unlines+                       [ "Could not find 'refactor' executable"+                       , "Tried to find '" ++ excPath ++ "' on the PATH"+                       , "'refactor' is provided by the 'apply-refact' package and has to be installed"+                       , "<https://github.com/mpickering/apply-refact>"+                       ]++runRefactoring :: FilePath -> FilePath -> FilePath -> [Extension] -> [Extension] -> String -> IO ExitCode+runRefactoring rpath fin hints enabled disabled opts =  do+    let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]+          ++ [arg | e <- enabled, arg <- ["-X", show e]]+          ++ [arg | e <- disabled, arg <- ["-X", "No" ++ show e]]+    whenLoud $ putStrLn $ "Running refactor: " ++ showCommandForUser rpath args+    (_, _, _, 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++minRefactorVersion :: Version+minRefactorVersion = makeVersion [0,9,1,0]
src/Report.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards #-}  module Report(writeReport) where@@ -5,20 +6,19 @@ import Idea import Data.Tuple.Extra import Data.List.Extra+import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Version-import System.FilePath-import System.IO.Extra-import HSE.All import Timing import Paths_hlint import HsColour+import EmbedData+import GHC.Util qualified as GHC   writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO ()-writeTemplate dataDir content to = do-    src <- readFile' $ dataDir </> "report_template.html"-    writeFile to $ unlines $ concatMap f $ lines src+writeTemplate dataDir content to =+    writeFile to $ unlines $ concatMap f $ lines reportTemplate     where         f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content         f x = [x]@@ -28,8 +28,8 @@ writeReport dataDir file ideas = timedIO "Report" file $ writeTemplate dataDir inner file     where         generateIds :: [String] -> [(String,Int)] -- sorted by name-        generateIds = map (head &&& length) . group -- must be already sorted-        files = generateIds $ sort $ map (srcSpanFilename . ideaSpan) ideas+        generateIds = map (NE.head &&& length) . NE.group -- must be already sorted+        files = generateIds $ sort $ map (GHC.srcSpanFilename . ideaSpan) ideas         hints = generateIds $ map hintName $ sortOn (negate . fromEnum . ideaSeverity &&& hintName) ideas         hintName x = show (ideaSeverity x) ++ ": " ++ ideaHint x @@ -42,10 +42,10 @@                          ("HINTS",list "hint" hints),("FILES",list "file" files)]          content = concatMap (\i -> writeIdea (getClass i) i) ideas-        getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcSpanFilename $ ideaSpan i)+        getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (GHC.srcSpanFilename $ ideaSpan i)             where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs -        list mode = zipWith f [0..]+        list mode = zipWithFrom f 0             where                 f i (name,n) = "<li><a id=" ++ show id ++ " href=\"javascript:show('" ++ id ++ "')\">" ++                                escapeHTML name ++ " (" ++ show n ++ ")</a></li>"@@ -55,7 +55,7 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} =     ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "<br/>"+    ,escapeHTML (GHC.showSrcSpan ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "<br/>"     ,"Found<br/>"     ,hsColourHTML ideaFrom] ++     (case ideaTo of
+ src/SARIF.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Description: Formats hlint ideas in the Statis Analysis Results Interchange Format (SARIF).+License: BSD-3-Clause++Supports the conversion of a list of HLint 'Idea's into SARIF.++SARIF (Static Analysis Results Interchange Format) is an open interchange format+for storing results from static analyses.+-}+module SARIF ( printIdeas+             , showIdeas+             , toJSONEncoding+             -- * See also+             --+             -- $references+             ) where++import Data.Aeson hiding (Error)+import Data.Aeson.Encoding+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as B+import Data.Text.Lazy (Text)+import Data.Version (showVersion)+import GHC.Util+import Idea+import Paths_hlint (version)++-- | Print the given ideas to standard output.+--+-- For example:+--+-- >>> hlint ["src"] >>= printIdeas+--+-- For printing ideas in SARIF without dependent modules+-- having to import "Data.Aeson" or "Data.ByteString.Lazy".+printIdeas :: [Idea] -> IO ()+printIdeas = B.putStr . showIdeas++-- | Format the given ideas in SARIF.+--+-- For converting ideas to SARIF without dependent modules+-- having to import "Data.Aeson".+showIdeas :: [Idea] -> ByteString+showIdeas = encodingToLazyByteString . toJSONEncoding++-- | Converts the given ideas to a "Data.Aeson" encoding in SARIF.+toJSONEncoding :: [Idea] -> Encoding+toJSONEncoding = pairs . sarif++-- | Converts the given object to a top-level @sarifLog@ object.+--+-- See section 3.13 "sarifLog object", SARIF specification.+sarif :: [Idea] -> Series+sarif ideas =+  pair "version" (lazyText "2.1.0") <>+  pair "$schema" (lazyText schemaURI) <>+  pair "runs" runs+  where runs = list pairs [ pair "tool" (pairs tool) <>+                            pair "results" (list (pairs . toResult) ideas) ]++-- | A @tool@ object describing what created the output.+--+-- Obviously, it will describe that HLint created the output.+--+-- See section 3.18 "tool object", SARIF specification.+tool :: Series+tool = pair "driver" $ pairs $+  pair "name" (lazyText "hlint") <>+  pair "version" (string $ showVersion version) <>+  pair "informationUri" (lazyText hlintURI)++-- | Converts a given idea into a @result@ object.+--+-- It will describe the hint, the severity, suggestions for fixes, etc.+--+-- See section 3.27 "result object", SARIF specification.+toResult :: Idea -> Series+toResult idea@Idea{..} =+  pair "message" (pairs $ pair "text" $ string $ show idea) <>+  pair "level" (lazyText $ showSeverity ideaSeverity) <>+  pair "locations" (list (pairs . toLocation) [idea]) <>+  pair "fixes" (list (pairs . toFix) [idea]) <>+  -- Use 'ideaHint' as the rule identifier.+  --+  -- "ruleId" is supposed to a stable, opaque identifier.+  -- 'ideaHint' is not opaque, nor is it quite guaranteed to be stable,+  -- but they will usually be stable enough, and disabling a hint is+  -- based on the name in 'ideaHint'.+  --+  -- Most importantly, there is no requirement that "ruleId"+  -- be a /unique/ identifier.+  pair "ruleId" (string ideaHint)++-- | Convert HLint severity to SARIF level.+--+-- See section 3.58.6 "level property", SARIF specification.+showSeverity :: Severity -> Text+showSeverity Error = "error"+showSeverity Warning = "warning"+showSeverity Suggestion = "note"+showSeverity Ignore = "none"++-- | Converts the location information in a given idea to a @location@ object.+--+-- See section 3.28 "location object", SARIF specification.+toLocation :: Idea -> Series+toLocation idea@Idea{ideaSpan=SrcSpan{..}, ..} =+  physicalLocation <> logicalLocations ideaModule ideaDecl+  where physicalLocation = pair "physicalLocation" $ pairs $+          pair "artifactLocation"+              (pairs $ pair "uri" (string srcSpanFilename)) <>+          pair "region" (pairs $ toRegion idea)++        logicalLocations [mod] [decl] = pair "logicalLocations" $+          list pairs [ pair "name" (string decl) <>+                       pair "fullyQualifiedName" (string $ mod ++ "." ++ decl) ]+          -- It would be nice to include whether it is a function or type+          -- in the "kind" field, but we do not have that information.++        -- If the lists are empty, then there is obviously no logical location.+        -- Logical location is still omitted when the lists are not singleton,+        -- because the associations between modules and declarations are+        -- not clear.+        logicalLocations _ _ = mempty++-- | Converts a given idea to a @fix@ object.+--+-- It will suggest how code can be improved to deal with an issue.+-- This includes the file to be changed and how to change it.+--+-- See section 3.55 "fix object", SARIF specification.+toFix :: Idea -> Series+toFix idea@Idea{..} =+  pair "description" (pairs $ pair "text" $ string ideaHint) <>+  pair "artifactChanges" (list (pairs . toChange) [idea])++-- | Converts a given idea to a @artifactChange@ object.+--+-- It will describe the details as to how the code can be changed.+-- I.e., the text to remove and what it should be replaced with.+--+-- See section 3.56 "artifactChange object", SARIF specification.+toChange :: Idea -> Series+toChange idea@Idea{ideaSpan=SrcSpan{..}, ..} =+  pair "artifactLocation" (pairs uri) <>+  pair "replacements" (list pairs [deleted <> inserted])+  where uri  = pair "uri" $ string srcSpanFilename+        deleted = pair "deletedRegion" $ pairs $ toRegion idea+        inserted = maybe mempty insertedContent ideaTo+        insertedContent = pair "insertedContent" . pairs . pair "text" . string++-- | Converts the source span in an idea to a SARIF region.+--+-- See 3.30 "region object", SARIF specification.+toRegion :: Idea -> Series+toRegion Idea{ideaSpan=SrcSpan{..}, ..} =+  pair "startLine" (int srcSpanStartLine') <>+  pair "startColumn" (int srcSpanStartColumn) <>+  pair "endLine" (int srcSpanEndLine') <>+  pair "endColumn" (int srcSpanEndColumn)++-- | URI to SARIF schema definition.+schemaURI :: Text+schemaURI = "https://raw.githubusercontent.com/" <>+            "oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json"++-- | URI to HLint home page.+hlintURI :: Text+hlintURI = "https://github.com/ndmitchell/hlint"++-- $references+--+-- * [SARIF Tutorials](https://github.com/microsoft/sarif-tutorials)+-- * [Static Analysis Results Interchange Format](https://docs.oasis-open.org/sarif/sarif/v2.1.0/cs01/sarif-v2.1.0-cs01.html), version 2.1.0
+ src/Summary.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}++module Summary (generateMdSummary, generateJsonSummary, generateExhaustiveConfig) where++import Data.Map qualified as Map+import Control.Monad.Extra+import System.FilePath+import Data.List.NonEmpty qualified as NE+import Data.List.Extra+import System.Directory++import Idea+import Apply+import Hint.Type+import Hint.All+import Config.Type+import Test.Annotations+import Deriving.Aeson+import Data.Aeson (encode)+import Data.ByteString.Char8 (unpack)+import Data.ByteString.Lazy (toStrict)++data Summary = Summary+  { sBuiltinRules :: ![BuiltinHint]+  , sLhsRhsRules :: ![HintRule]+  } deriving (Show, Generic)+  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "s", CamelToSnake)] Summary++data BuiltinHint = BuiltinHint+  { hName :: !String+  , hSeverity :: !Severity+  , hRefactoring :: !Bool+  , hCategory :: !String+  , hExamples :: ![BuiltinExample]+  } deriving (Show, Eq, Ord, Generic)+  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "h", CamelToSnake)] BuiltinHint++data BuiltinKey = BuiltinKey+  { kName :: !String+  , kSeverity :: !Severity+  , kRefactoring :: !Bool+  , kCategory :: !String+  } deriving (Show, Eq, Ord)++data BuiltinExample = BuiltinExample+    { eContext :: !String+    , eFrom :: !String+    , eTo :: !(Maybe String)+    } deriving (Show, Eq, Ord, Generic)+    deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "e", CamelToSnake)] BuiltinExample++dedupBuiltin :: [(BuiltinKey, BuiltinExample)] -> [BuiltinHint]+dedupBuiltin = fmap makeHint . Map.toAscList . Map.fromListWith (<>) . fmap exampleToList where+  exampleToList (k, e) = (k, [e])+  makeHint (BuiltinKey{..}, examples) = BuiltinHint+    kName+    kSeverity+    kRefactoring+    kCategory+    examples++-- | The summary of built-in hints is generated by running the test cases in+-- @src/Hint/*.hs@.+mkBuiltinSummary :: IO [BuiltinHint]+mkBuiltinSummary = concatForM builtinHints $ \(category, hint) -> do+    let file = "src/Hint" </> category <.> "hs"+    b <- doesFileExist file+    if not b then do+        putStrLn $ "Couldn't find source hint file " ++ file ++ ", some hints will be missing"+        pure []+     else do+        tests <- parseTestFile file+        fmap dedupBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do+            m <- parseModuleEx defaultParseFlags file (Just inp)+            pure $ case m of+                Right m -> map (ideaToValue category inp) $ applyHints [] hint [m]+                Left _ -> []+    where+        ideaToValue :: String -> String -> Idea -> (BuiltinKey, BuiltinExample)+        ideaToValue category inp Idea{..} = (k, v)+            where+                -- make sure Windows/Linux don't differ on path separators+                to = fmap (\x -> if "Combine with " `isPrefixOf` x then replace "\\" "/" x else x) ideaTo+                k = BuiltinKey ideaHint ideaSeverity (notNull ideaRefactoring) category+                v = BuiltinExample inp ideaFrom to++getSummary :: [Setting] -> IO Summary+getSummary settings = do+  builtinHints <- mkBuiltinSummary+  let lhsRhsHints = [hint | SettingMatchExp hint <- settings]+  pure $ Summary builtinHints lhsRhsHints++jsonToString :: ToJSON a => a -> String+jsonToString = unpack . toStrict . encode++-- | Generate a summary of hints, including built-in hints and YAML-configured hints+generateMdSummary :: [Setting] -> IO String+generateMdSummary = fmap genSummaryMd . getSummary++generateJsonSummary :: [Setting] -> IO String+generateJsonSummary = fmap jsonToString . getSummary++generateExhaustiveConfig :: Severity -> [Setting] -> IO String+generateExhaustiveConfig severity = fmap (genExhaustiveConfig severity) . getSummary++genExhaustiveConfig :: Severity -> Summary -> String+genExhaustiveConfig severity Summary{..} = unlines $+  [ "# HLint configuration file"+  , "# https://github.com/ndmitchell/hlint"+  , "##########################"+  , ""+  , "# This file contains a template configuration file, which is typically"+  , "# placed as .hlint.yaml in the root of your project"+  , ""+  , "# All built-in hints"+  ]+    ++ (mkLine <$> sortDedup (hName <$> sBuiltinRules))+    ++ ["", "# All LHS/RHS hints"]+    ++ (mkLine <$> sortDedup (hintRuleName <$> sLhsRhsRules))+  where+    sortDedup = fmap (NE.head . NE.fromList) . group . sort+    mkLine name = "- " <> show severity <> ": {name: " <> jsonToString name <> "}"++genSummaryMd :: Summary -> String+genSummaryMd Summary{..} = unlines $+  [ "# Summary of Hints"+  , ""+  , "This page is auto-generated from `hlint --generate-summary`."+  ] +++  concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints | (group, hints) <- groupHintsByCategory sBuiltinRules] +++  [ ""+  , "## Configured hints"+  , ""+  ]+  ++ lhsRhsTable sLhsRhsRules+  where+    groupHintsByCategory = Map.toAscList . Map.fromListWith (<>) . fmap keyCategory+    keyCategory hint = (hCategory hint, [hint])++row :: [String] -> [String]+row xs = ["<tr>"] ++ xs ++ ["</tr>"]++-- | Render using <code> if it is single-line, otherwise using <pre>.+haskell :: String -> [String]+haskell s+  | '\n' `elem` s = ["<pre>", s, "</pre>"]+  | otherwise = ["<code>", s, "</code>", "<br>"]++builtinTable :: [BuiltinHint] -> [String]+builtinTable builtins =+  ["<table>"]+  ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]+  ++ concatMap showBuiltin builtins+  ++ ["</table>"]++showBuiltin :: BuiltinHint -> [String]+showBuiltin BuiltinHint{..} = row1+  where+    row1 = row $+      [ "<td>" ++ hName ++ "</td>", "<td>"]+      ++ showExample (NE.head (NE.fromList hExamples))+      ++ ["Does not support refactoring." | not hRefactoring]+      ++ ["</td>"] +++      [ "<td>" ++ show hSeverity ++ "</td>"+      ]+    showExample BuiltinExample{..} =+      ["Example: "]+        ++ haskell eContext+        ++ ["Found:"]+        ++ haskell eFrom+        ++ ["Suggestion:"]+        ++ haskell eTo'+      where+      eTo' = case eTo of+        Nothing -> ""+        Just "" -> "Perhaps you should remove it."+        Just s -> s++lhsRhsTable :: [HintRule] -> [String]+lhsRhsTable hints =+  ["<table>"]+  ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]+  ++ concatMap showLhsRhs hints+  ++ ["</table>"]++showLhsRhs :: HintRule -> [String]+showLhsRhs HintRule{..} = row $+  [ "<td>" ++ hintRuleName ++ "</td>"+  , "<td>"+  , "LHS:"+  ]+  ++ haskell (show hintRuleLHS)+  ++ ["RHS:"]+  ++ haskell (show hintRuleRHS)+  +++  [ "</td>"+  , "<td>" ++ show hintRuleSeverity ++ "</td>"+  ]
src/Test/All.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}  module Test.All(test) where  import Control.Exception-import System.Console.CmdArgs import Control.Monad import Control.Monad.IO.Class import Data.Char+import Data.Either.Extra+import Data.Foldable import Data.List+import Data.Maybe import System.Directory import System.FilePath import Data.Functor@@ -17,58 +19,59 @@ import Config.Type import Config.Read import CmdLine-import HSE.All+import Refact import Hint.All-import Test.Util-import Test.InputOutput import Test.Annotations-import Test.Translate+import Test.InputOutput+import Test.Util import System.IO.Extra+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable   test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int-test CmdTest{..} main dataDir files = do+test CmdMain{..} main dataDir files = do+    rpath <- refactorPath (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)+     (failures, ideas) <- withBuffering stdout NoBuffering $ withTests $ do         hasSrc <- liftIO $ doesFileExist "hlint.cabal"-        useSrc <- return $ hasSrc && null files-        testFiles <- if files /= [] then return files else do+        let useSrc = hasSrc && null files+        testFiles <- if files /= [] then pure files else do             xs <- liftIO $ getDirectoryContents dataDir-            return [dataDir </> x | x <- xs, takeExtension x `elem` [".hs",".yml",".yaml"]-                                , not $ "HLint_" `isPrefixOf` takeBaseName x]+            pure [dataDir </> x | x <- xs, takeExtension x `elem` [".yml",".yaml"]]         testFiles <- liftIO $ forM testFiles $ \file -> do-            hints <- readFilesConfig [(file, Nothing)]-            return (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))+            hints <- readFilesConfig [(file, Nothing),("CommandLine.yaml", Just "- group: {name: testing, enabled: true}")]+            pure (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))         let wrap msg act = do liftIO $ putStr (msg ++ " "); act; liftIO $ putStrLn "" -        liftIO $ putStrLn "Testing"+        liftIO $ putStrLn $ "Testing (" ++ (if isRight rpath then "with" else "WITHOUT") ++ " refactoring)"         liftIO $ checkCommentedYaml $ dataDir </> "default.yaml"         when useSrc $ wrap "Source annotations" $ do             config <- liftIO $ readFilesConfig [(".hlint.yaml",Nothing)]             forM_ builtinHints $ \(name,_) -> do                 progress-                testAnnotations (Builtin name : if name == "Restrict" then config else []) $ "src/Hint" </> name <.> "hs"+                testAnnotations (Builtin name : if name == "Restrict" then config else [])+                                ("src/Hint" </> name <.> "hs")+                                (eitherToMaybe rpath)         when useSrc $ wrap "Input/outputs" $ testInputOutput main          wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles-        wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file-        when cmdTypeCheck $ wrap "Hint typechecking" $-            progress >> testTypeCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]-        when cmdQuickCheck $ wrap "Hint QuickChecking" $-            progress >> testQuickCheck cmdDataDir cmdTempDir [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"]+        wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file (eitherToMaybe rpath)          when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"-        getIdeas-    whenLoud $ mapM_ print ideas-    return failures +    case rpath of+        Left refactorNotFound -> putStrLn $ unlines [refactorNotFound, "Refactoring tests skipped"]+        _ -> pure ()+    pure failures + --------------------------------------------------------------------- -- VARIOUS SMALL TESTS  -- Check all hints in the standard config files get sensible names testNames :: [Setting] -> Test () testNames hints = sequence_-    [ failed ["No name for the hint " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS]+    [ failed ["No name for the hint " ++ unsafePrettyPrint hintRuleLHS ++ " ==> " ++ unsafePrettyPrint hintRuleRHS]     | SettingMatchExp x@HintRule{..} <- hints, hintRuleName == defaultHintName]
src/Test/Annotations.hs view
@@ -1,51 +1,71 @@-{-# LANGUAGE PatternGuards, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-}  -- | Check the <TEST> annotations within source and hint files.-module Test.Annotations(testAnnotations) where+module Test.Annotations(testAnnotations, parseTestFile, TestCase(..)) where  import Control.Exception.Extra-import Data.Tuple.Extra+import Control.Monad+import Control.Monad.IO.Class import Data.Char import Data.Either.Extra+import Data.Function+import Data.Functor import Data.List.Extra import Data.Maybe-import Control.Monad+import Data.Tuple.Extra+import System.Exit import System.FilePath-import Control.Monad.IO.Class-import Data.Function-import Data.Yaml-import qualified Data.ByteString.Char8 as BS+import System.IO.Extra+import GHC.All+import Data.ByteString.Char8 qualified as BS  import Config.Type import Idea import Apply-import HSE.All+import Extension+import Refact import Test.Util-import Data.Functor import Prelude import Config.Yaml+import GHC.Data.FastString +import GHC.Util+import GHC.Types.SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +#ifdef HS_YAML++import Data.YAML.Aeson (decode1Strict)+import Data.YAML (Pos)+import Data.ByteString (ByteString)++decodeEither' :: ByteString -> Either (Pos, String) ConfigYaml+decodeEither' = decode1Strict++#else++import Data.Yaml++#endif+ -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs-data TestCase = TestCase SrcLoc String (Maybe String) [Setting] deriving (Show)+data TestCase = TestCase SrcLoc Refactor String (Maybe String) [Setting] deriving (Show) -testAnnotations :: [Setting] -> FilePath -> Test ()-testAnnotations setting file = do+data Refactor = TestRefactor | SkipRefactor deriving (Eq, Show)++testAnnotations :: [Setting] -> FilePath -> Maybe FilePath -> Test ()+testAnnotations setting file rpath = do     tests <- liftIO $ parseTestFile file     mapM_ f tests     where-        f (TestCase loc inp out additionalSettings) = do+        f (TestCase loc refact inp out additionalSettings) = do             ideas <- liftIO $ try_ $ do                 res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp                 evaluate $ length $ show res-                return res--            -- the hints from data/Test.hs are really fake hints we don't actually deploy-            -- so don't record them-            when (takeFileName file /= "Test.hs") $-                either (const $ return ()) addIdeas ideas+                pure res              let good = case (out, ideas) of                     (Nothing, Right []) -> True@@ -54,19 +74,36 @@             let bad =                     [failed $                         ["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)"-                        ,"SRC: " ++ showSrcLoc loc+                        ,"SRC: " ++ unsafePrettyPrint loc                         ,"INPUT: " ++ inp] ++-                        map ("OUTPUT: " ++) (either (return . show) (map show) ideas) +++                        map ("OUTPUT: " ++) (either (pure . show) (map show) ideas) ++                         ["WANTED: " ++ fromMaybe "<failure>" out]                         | not good] ++                     [failed                         ["TEST FAILURE (BAD LOCATION)"-                        ,"SRC: " ++ showSrcLoc loc+                        ,"SRC: " ++ unsafePrettyPrint loc                         ,"INPUT: " ++ inp                         ,"OUTPUT: " ++ show i]-                        | i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]-            if null bad then passed else sequence_ bad+                        | i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = srcSpanStart ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]+                        -- TODO: shouldn't these checks be == -1 instead? +            -- Skip refactoring test if the hlint test failed, or if the+            -- test is annotated with @NoRefactor.+            let skipRefactor = notNull bad || refact == SkipRefactor+            badRefactor <- if skipRefactor then pure [] else liftIO $ do+                refactorErr <- case ideas of+                    Right [] -> testRefactor rpath Nothing inp+                    Right [idea] -> testRefactor rpath (Just idea) inp+                    -- Skip refactoring test if there are multiple hints+                    _ -> pure []+                pure $ [failed $+                           ["TEST FAILURE (BAD REFACTORING)"+                           ,"SRC: " ++ unsafePrettyPrint loc+                           ,"INPUT: " ++ inp] ++ refactorErr+                           | notNull refactorErr]++            if null bad && null badRefactor then passed else sequence_ (bad ++ badRefactor)+         match "???" _ = True         match (word1 -> ("@Message",msg)) i = ideaHint i == msg         match (word1 -> ("@Note",note)) i = map show (ideaNote i) == [note]@@ -81,13 +118,16 @@ parseTestFile :: FilePath -> IO [TestCase] parseTestFile file =     -- we remove all leading # symbols since Yaml only lets us do comments that way-    f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file+    f Nothing TestRefactor . zipFrom 1 . map (dropPrefix "# ") . lines <$> readFile file     where         open :: String -> Maybe [Setting]         open line           |  "<TEST>" `isPrefixOf` line =              let suffix = dropPrefix "<TEST>" line-                 config = decodeEither'  $ BS.pack suffix+                 config =+                   if isBuiltinYaml file+                     then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack suffix+                     else mapRight getConfigYamlUser $ decodeEither' $ BS.pack suffix              in case config of                   Left err -> Just []                   Right config -> Just $ settingsFromConfigYaml [config]@@ -96,19 +136,58 @@         shut :: String -> Bool         shut = isPrefixOf "</TEST>" -        f :: Maybe [Setting] -> [(Int, String)] -> [TestCase]-        f Nothing ((i,x):xs) = f (open x) xs-        f (Just s)  ((i,x):xs)-            | shut x = f Nothing xs-            | null x || "-- " `isPrefixOf` x = f (Just s) xs-            | "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) $ (i,init x++"\n"++y):ys-            | otherwise = parseTest file i x s : f (Just s) xs-        f _ [] = []+        f :: Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]+        f Nothing _ ((i,x):xs) = f (open x) TestRefactor xs+        f (Just s) refact ((i,x):xs)+            | shut x = f Nothing TestRefactor xs+            | Just (x',_) <- stripInfix "@NoRefactor" x =+                f (Just s) SkipRefactor ((i, trimEnd x' ++ ['\\' | "\\" `isSuffixOf` x]) : xs)+            | null x || "-- " `isPrefixOf` x = f (Just s) refact xs+            | Just x <- stripSuffix "\\" x, (_,y):ys <- xs = f (Just s) refact $ (i,x++"\n"++y):ys+            | otherwise = parseTest refact file i x s : f (Just s) TestRefactor xs+        f _ _ [] = []  -parseTest file i x = uncurry (TestCase (SrcLoc file i 0)) $ f x+parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase+parseTest refact file i x = uncurry (TestCase (mkSrcLoc (mkFastString file) i 0) refact) $ f x     where         f x | Just x <- stripPrefix "<COMMENT>" x = first ("--"++) $ f x-        f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ dropWhile isSpace xs)+        f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ trimStart xs)         f (x:xs) = first (x:) $ f xs         f [] = ([], Nothing)+++-- Returns an empty list if the refactoring test passes, otherwise+-- returns error messages.+testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String]+-- Skip refactoring test if the refactor binary is not found.+testRefactor Nothing _ _ = pure []+-- Skip refactoring test if there is no hint.+testRefactor _ Nothing _ = pure []+-- Skip refactoring test if the hint has no suggestion (such as "Parse error" or "Avoid restricted function").+testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure []+-- Skip refactoring test if the hint does not support refactoring.+testRefactor _ (Just idea) _ | null (ideaRefactoring idea) = pure []+testRefactor (Just rpath) (Just idea) inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do+    let refact = (show idea, ideaRefactoring idea)+        -- Ignores spaces and semicolons since unsafePrettyPrint may differ from apply-refact.+        process = filter (\c -> not (isSpace c) && c /= ';')+        matched expected g actual = process expected `g` process actual+        x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y+    writeFile tempInp inp+    writeFile tempHints (show [refact])+    exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace"+    refactored <- readFile tempInp+    pure $ case exitCode of+        ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]+        ExitSuccess -> case ideaTo idea of+            -- The hint's suggested replacement is @Just ""@, which means the hint+            -- suggests removing something from the input. The refactoring output+            -- should be a proper subsequence of the input.+            Just "" | not (matched refactored isProperSubsequenceOf inp) ->+                ["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored]+            -- The hint has a suggested replacement. The suggested replacement+            -- should be a substring of the refactoring output.+            Just to | not (matched to isInfixOf refactored) ->+                ["Refactor output is expected to contain: " ++ to, "Actual: " ++ refactored]+            _ -> []
src/Test/InputOutput.hs view
@@ -17,6 +17,8 @@ import System.Exit import System.IO.Extra import Prelude+import Data.Version (showVersion)+import Paths_hlint (version)  import Test.Util @@ -24,10 +26,10 @@ testInputOutput :: ([String] -> IO ()) -> Test () testInputOutput main = do     xs <- liftIO $ getDirectoryContents "tests"-    xs <- return $ filter ((==) ".test" . takeExtension) xs+    xs <- pure $ filter ((==) ".test" . takeExtension) xs     forM_ xs $ \file -> do         ios <- liftIO $ parseInputOutputs <$> readFile ("tests" </> file)-        forM_ (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do+        forM_ (zipFrom 1 ios) $ \(i,io@InputOutput{..}) -> do             progress             liftIO $ forM_ files $ \(name,contents) -> do                 createDirectoryIfMissing True $ takeDirectory name@@ -48,6 +50,8 @@     where         z = InputOutput "unknown" [] [] "" Nothing         interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"]+        outputTemplateVars = [ ("__VERSION__", showVersion version) ]+        substituteTemplateVars = mconcatMap (uncurry replace) outputTemplateVars          f io ((stripPrefix "RUN " -> Just flags):xs) = f io{run = splitArgs flags} xs         f io ((stripPrefix "EXIT " -> Just code):xs) = f io{exit = Just $ let i = read code in if i == 0 then ExitSuccess else ExitFailure i} xs@@ -57,7 +61,7 @@         f io [] = [io | io /= z]         f io (x:xs) = error $ "Unknown test item, " ++ x -        g = first (reverse . dropWhile null . reverse) . break interest+        g = first (fmap substituteTemplateVars . reverse . dropWhile null . reverse) . break interest   ---------------------------------------------------------------------@@ -71,7 +75,7 @@         handle (\(e::ExitCode) -> writeIORef code e) $         bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run     code <- liftIO $ readIORef code-    (want,got) <- return $ matchStarStar (lines output) got+    (want,got) <- pure $ matchStarStar (lines output) got      if maybe False (/= code) exit then         failed@@ -96,7 +100,12 @@ -- | First string may have stars in it (the want) matchStar :: String -> String -> Bool matchStar ('*':xs) ys = any (matchStar xs) $ tails ys-matchStar (x:xs) (y:ys) = x == y && matchStar xs ys+matchStar ('/':x:xs) ('\\':'\\':ys) | x /= '/' = matchStar (x:xs) ys -- JSON escaped newlines+matchStar (x:xs) (y:ys) = eq x y && matchStar xs ys+    where+        -- allow path differences between Windows and Linux+        eq '/' y = isPathSeparator y+        eq x y = x == y matchStar [] [] = True matchStar _ _ = False
− src/Test/Proof.hs 
@@ -1,185 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards, FlexibleContexts #-}---- | Check the coverage of the hints given a list of Isabelle theorems-module Test.Proof(proof) where--import Data.Tuple.Extra-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.State-import Data.Char-import Data.List.Extra-import Data.Maybe-import Data.Function-import System.FilePath-import Config.Type-import HSE.All-import Prelude---data Theorem = Theorem-    {original :: Maybe HintRule-    ,location :: String-    ,lemma :: String-    }--instance Eq Theorem where-    t1 == t2 = lemma t1 == lemma t2--instance Ord Theorem where-    compare t1 t2 = compare (lemma t1) (lemma t2)--instance Show Theorem where-    show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"-        where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"--proof :: [FilePath] -> [Setting] -> FilePath -> IO ()-proof reports hints thy = do-    got <- isabelleTheorems (takeFileName thy) <$> readFile thy-    let want = nubOrd $ hintTheorems hints-    let unused = got \\ want-    let missing = want \\ got-    let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $-                  sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing-    let summary = table $ let (*) = (,) in-            ["HLint hints" * want-            ,"HOL proofs" * got-            ,"Useful proofs" * (got `intersect` want)-            ,"Unused proofs" * unused-            ,"Unproved hints" * missing] ++-            [("  " ++ name) * ps | (name,ps) <- reasons]-    putStr $ unlines summary-    forM_ reports $ \report -> do-        let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons-        writeFile report $ unlines $ summary ++ "" : concat-            [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]-        putStrLn $ "Report written to " ++ report-    where-        table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]-            where n = maximum $ map (length . fst) xs---missingFuncs = let a*b = [(b,a) | b <- words b] in concat-    ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"-    ,"Exit" * "exitSuccess"-    ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"-    ,"Show" * "show shows showIntAtBase"-    ,"Read" * "reads read"-    ,"String" * "lines unlines words unwords"-    ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"-    ,"Functor" * "fmap"-    ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"-    ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"-    ,"Arrow" * "second first (***) (&&&)"-    ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"-    ,"Exception" * "catch handle catchJust bracket error toException"-    ,"WeakPtr" * "mkWeak"-    ]----- | Guess why a theorem is missing-classifyMissing :: Theorem -> String-classifyMissing Theorem{original = Just HintRule{..}}-    | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"-    | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"-    | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name S) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v-classifyMissing _ = "?unknown"----- Extract theorems out of Isabelle code (HLint.thy)-isabelleTheorems :: FilePath -> String -> [Theorem]-isabelleTheorems file = find . lexer 1-    where-        find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest-        find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest-        find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =-            Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\<Longrightarrow> " ++ lemma) : find rest--        find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest-        find (x:xs) = find xs-        find [] = []--        lexer i x-            | i `seq` False = []-            | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b-            | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "-            | x:xs <- x, isSpace x = lexer (add [x] i) xs-            | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b-        lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs-        lexer i [] = []--        add s i = length (filter (== '\n') s) + i--        breaks s x | Just x <- stripPrefix s x = ("",x)-        breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)-        breaks s [] = ([],[])---reparen :: Setting -> Setting-reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}-    where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x-          badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."-          badInfix _ = False-reparen x = x----- Extract theorems out of the hints-hintTheorems :: [Setting] -> [Theorem]-hintTheorems xs =-    [ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b-    | SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]-    where-        loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln--        subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]-        funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"-        ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"-        pre = flip elem $ words "eq neq dollar dollarBang"-        cons = subs "True=TT False=FF"--        typeclasses hintRuleNotes x = foldr f x hintRuleNotes-            where-                f (ValidInstance cls var) x = evalState (transformM g x) True-                    where g v@Var{} | v ~= var = do-                                b <- get; put False-                                return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v-                          g v = return v :: State Bool Exp_-                f _  x = x--        relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\<sqsubseteq> " ++ b-                               | DecreasesLaziness `elem` hintRuleNotes = b ++ " \\<sqsubseteq> " ++ a-                               | otherwise = a ++ " = " ++ b-            where lazier IncreasesLaziness = True-                  lazier RemovesError{} = True-                  lazier _ = False--        assumes (App _ op var)-            | op ~= "isNat" = "le\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "-            | op ~= "isNegZero" = "gt\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "-        assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\<noteq> \\<bottom> \\<Longrightarrow> "-        assumes _ = ""--        exp1 = exp . transformBi unqual--        -- Syntax translations-        exp (App _ a b) = exp a ++ "\\<cdot>" ++ exp b-        exp (Paren _ x) = "(" ++ exp x ++ ")"-        exp (Var _ x) | Just x <- funs $ prettyPrint x = x-        exp (Con _ (Special _ (TupleCon _ _ i))) = "\\<langle>" ++ replicate (i-1) ',' ++ "\\<rangle>"-        exp (Con _ x) | Just x <- cons $ prettyPrint x = x-        exp (Tuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map exp xs) ++ "\\<rangle>"-        exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c-        exp (Lambda _ xs y) = "\\<Lambda> " ++ unwords (map pat xs) ++ ". " ++ exp y-        exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =-            if pre op then op ++ "\\<cdot>" ++ exp (paren x) ++ "\\<cdot>" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y--        -- Translations from the Haskell 2010 report-        exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4-        exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5-        exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5-        exp x = prettyPrint x--        pat (PTuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map pat xs) ++ "\\<rangle>"-        pat x = prettyPrint x--        fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
− src/Test/Translate.hs 
@@ -1,105 +0,0 @@---- | Translate the hints to Haskell and run with GHC.-module Test.Translate(testTypeCheck, testQuickCheck) where--import Control.Monad-import Control.Monad.IO.Class-import Data.List.Extra-import System.IO.Extra-import Data.Maybe-import System.Process-import System.Exit-import System.FilePath--import Config.Type-import HSE.All-import Test.Util---runMains :: FilePath -> FilePath -> [String] -> Test ()-runMains datadir tmpdir xs = do-    res <- liftIO $ (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do-        ms <- forM (zip [1..] xs) $ \(i,x) -> do-            let m = "I" ++ show i-            writeFile (dir </> m <.> "hs") $ replace "module Main" ("module " ++ m) x-            return m-        writeFile (dir </> "Main.hs") $ unlines $-            ["import qualified " ++ m | m <- ms] ++-            ["main = do"] ++-            ["    " ++ m ++ ".main" | m <- ms]-        system $ "runhaskell -i" ++ dir ++ " -i" ++ datadir ++ " Main"-    replicateM_ (length xs) $ tested $ res == ExitSuccess----- | Given a set of hints, do all the HintRule hints type check-testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testTypeCheck = wrap toTypeCheck---- | Given a set of hints, do all the HintRule hints satisfy QuickCheck-testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test ()-testQuickCheck = wrap toQuickCheck--wrap :: ([HintRule] -> [String]) -> FilePath -> FilePath -> [[Setting]] -> Test ()-wrap f datadir tmpdir hints = runMains datadir tmpdir [unlines $ body [x | SettingMatchExp x <- xs] | xs <- hints]-    where-        body xs =-            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}"-            ,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}"-            ,"module Main(main) where"] ++-            concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++-            f xs--        -- Hack around haskell98 not being compatible with base anymore-        hackImport i@ImportDecl{importAs=Just a,importModule=b}-            | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}-        hackImport i = i--------------------------------------------------------------------------- TYPE CHECKING--toTypeCheck :: [HintRule] -> [String]-toTypeCheck hints =-    ["import HLint_TypeCheck hiding(main)"-    ,"main = return ()"] ++-    ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++-     prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing)-    | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)-    , let vs = map toNamed $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs-    , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)-    , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]--------------------------------------------------------------------------- QUICKCHECK--toQuickCheck :: [HintRule] -> [String]-toQuickCheck hints =-    ["import HLint_QuickCheck hiding(main)"-    ,"default(Maybe Bool,Int,Dbl)"-    ,prettyPrint $ PatBind an (toNamed "main") (UnGuardedRhs an $ toNamed "withMain" $$ Do an tests) Nothing]-    where-        str x = Lit an $ String an x (show x)-        int x = Lit an $ Int an (toInteger x) (show x)-        app = App an-        a $$ b = InfixApp an a (toNamed "$") b-        tests =-            [ Qualifier an $-                Let an (BDecls an [PatBind an (toNamed "t") (UnGuardedRhs an bod) Nothing]) $-                (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`-                 str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t"-            | (i, HintRule _ _ _ lhs rhs side note) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)-            , let vs = map (restrict side) $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs-            , let op = if any isRemovesError note then "?==>" else "==>"-            , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs)-            , let bod = if null vs then Paren an inner else Lambda an vs inner]--        restrict (Just side) v-            | any (=~= App an (toNamed "isNegZero") (toNamed v)) (universe side) = PApp an (toNamed "NegZero") [toNamed v]-            | any (=~= App an (toNamed "isNat") (toNamed v)) (universe side) = PApp an (toNamed "Nat") [toNamed v]-            | any (=~= App an (toNamed "isCompare") (toNamed v)) (universe side) = PApp an (toNamed "Compare") [toNamed v]-        restrict _ v = toNamed v---isRemovesError RemovesError{} = True-isRemovesError _ = False
src/Test/Util.hs view
@@ -2,8 +2,7 @@  module Test.Util(     Test, withTests,-    tested, passed, failed, progress,-    addIdeas, getIdeas+    passed, failed, progress,     ) where  import Idea@@ -12,7 +11,6 @@ import Control.Monad.IO.Class import Data.IORef - data S = S     {failures :: !Int     ,total :: !Int@@ -32,17 +30,7 @@     putStrLn $ if failures == 0         then "Tests passed (" ++ show total ++ ")"         else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"-    return (failures, res)--addIdeas :: [Idea] -> Test ()-addIdeas xs = do-    ref <- Test ask-    liftIO $ modifyIORef' ref $ \s -> s{ideas = xs : ideas s}--getIdeas :: Test [Idea]-getIdeas = do-    ref <- Test ask-    liftIO $ concat . reverse . ideas <$> readIORef ref+    pure (failures, res)  progress :: Test () progress = liftIO $ putChar '.'@@ -57,6 +45,3 @@     unless (null xs) $ liftIO $ putStrLn $ unlines $ "" : xs     ref <- Test ask     liftIO $ modifyIORef' ref $ \s -> s{total=total s+1, failures=failures s+1}--tested :: Bool -> Test ()-tested b = if b then passed else failed []
src/Timing.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-}  module Timing(     timed, timedIO,@@ -5,7 +6,7 @@     printTimings     ) where -import qualified Data.HashMap.Strict as Map+import Data.HashMap.Strict qualified as Map import Control.Exception import Data.IORef.Extra import Data.Tuple.Extra@@ -14,6 +15,7 @@ import System.Console.CmdArgs.Verbosity import System.Time.Extra import System.IO.Unsafe+import System.IO   type Category = String@@ -39,11 +41,13 @@ timedIO :: Category -> Item -> IO a -> IO a timedIO c i x = if not useTimings then x else do     let quiet = c == "Hint"-    unless quiet $ whenLoud $ putStr $ "Performing " ++ c ++ " of " ++ i ++ "... "+    unless quiet $ whenLoud $ do+        putStr $ "# " ++ c ++ " of " ++ i ++ "... "+        hFlush stdout     (time, x) <- duration x-    atomicModifyIORef' timings $ \mp -> (Map.insertWith (+) (c, i) time mp, ())+    atomicModifyIORef'_ timings $ Map.insertWith (+) (c, i) time     unless quiet $ whenLoud $ putStrLn $ "took " ++ showDuration time-    return x+    pure x  startTimings :: IO () startTimings = do
src/Util.hs view
@@ -1,21 +1,20 @@ {-# LANGUAGE ExistentialQuantification, Rank2Types #-}  module Util(-    defaultExtensions,     forceList,     gzip, universeParentBi,     exitMessage, exitMessageImpure,-    getContentsUTF8+    getContentsUTF8, wildcardMatch     ) where -import Data.List import System.Exit import System.IO import System.IO.Unsafe import Unsafe.Coerce import Data.Data-import Data.Generics.Uniplate.Operations-import Language.Haskell.Exts.Extension+import Data.Generics.Uniplate.DataOnly+import System.FilePattern+import Data.List.Extra   ---------------------------------------------------------------------@@ -59,28 +58,31 @@ --------------------------------------------------------------------- -- DATA.GENERICS.UNIPLATE.OPERATIONS -universeParent :: Uniplate a => a -> [(Maybe a, a)]+universeParent :: Data a => a -> [(Maybe a, a)] universeParent x = (Nothing,x) : f x     where-        f :: Uniplate a => a -> [(Maybe a, a)]+        f :: Data a => a -> [(Maybe a, a)]         f x = concat [(Just x, y) : f y | y <- children x] -universeParentBi :: Biplate a b => a -> [(Maybe b, b)]+universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi   ------------------------------------------------------------------------ LANGUAGE.HASKELL.EXTS.EXTENSION--defaultExtensions :: [Extension]-defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions+-- SYSTEM.FILEPATTERN -badExtensions =-    [Arrows -- steals proc-    ,TransformListComp -- steals the group keyword-    ,XmlSyntax, RegularPatterns -- steals a-b-    ,UnboxedTuples, UnboxedSums -- breaks (#) lens operator-    ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break-    ,DoRec, RecursiveDo -- breaks rec-    ,TypeApplications -- HSE fails on @ patterns-    ]+-- | Returns true if the pattern matches the string. For example:+--+-- >>> let isSpec = wildcardMatch "**.*Spec"+-- >>> isSpec "Example"+-- False+-- >>> isSpec "ExampleSpec"+-- True+-- >>> isSpec "Namespaced.ExampleSpec"+-- True+-- >>> isSpec "Deeply.Nested.ExampleSpec"+-- True+--+-- See this issue for details: <https://github.com/ndmitchell/hlint/issues/402>.+wildcardMatch :: FilePattern -> String -> Bool+wildcardMatch p m = let f = replace "." "/" in f p ?== f m
+ tests/bracket.test view
@@ -0,0 +1,29 @@+---------------------------------------------------------------------+RUN tests/bracket-slice.hs+FILE tests/bracket-slice.hs++fAnd :: [a -> Bool] -> a -> Bool+fAnd fs x = all ($x) fs++OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/bracket-slice-spaced.hs+FILE tests/bracket-slice-spaced.hs++fAnd :: [a -> Bool] -> a -> Bool+fAnd fs x = all ($ x) fs++OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/bracket-slice-plus.hs+FILE tests/bracket-slice-plus.hs++incAll :: [Int] -> Int -> [Int]+incAll ys x = map (+x) fs++OUTPUT+No hints
+ tests/cmdline.test view
@@ -0,0 +1,29 @@+---------------------------------------------------------------------+RUN lint tests/cmdline-lint.hs+FILE tests/cmdline-lint.hs++foo = map f (map g xs)++OUTPUT+tests/cmdline-lint.hs:2:7-22: Suggestion: Use map once+Found:+  map f (map g xs)+Perhaps:+  map (f . g) xs++1 hint++---------------------------------------------------------------------+RUN tests/cmdline-bare.hs+FILE tests/cmdline-bare.hs++foo = map f (map g xs)++OUTPUT+tests/cmdline-bare.hs:2:7-22: Suggestion: Use map once+Found:+  map f (map g xs)+Perhaps:+  map (f . g) xs++1 hint
+ tests/cpp.test view
@@ -0,0 +1,167 @@+---------------------------------------------------------------------+RUN tests/cpp-full.hs+FILE tests/cpp-full.hs+/* this is a test */++main = putStrLn $ show "Hello"+OUTPUT+tests/cpp-full.hs:3:8-30: Warning: Use print+Found:+  putStrLn $ show "Hello"+Perhaps:+  print "Hello"++1 hint++---------------------------------------------------------------------+RUN -XNoCPP tests/cpp-none.hs+FILE tests/cpp-none.hs+#include "Any/File.h"++main = print "Hello"+EXIT 0+OUTPUT+No hints++---------------------------------------------------------------------+RUN -XNoCPP tests/cpp-must-not-run.hs+FILE tests/cpp-must-not-run.hs+{-+#error Cpp has run+-}+main = undefined+EXIT 0+OUTPUT+No hints++---------------------------------------------------------------------+RUN --cpp-define FOO tests/cpp-ext-enable.hs+FILE tests/cpp-ext-enable.hs+{-# LANGUAGE CPP #-}+#if defined(FOO)+{-# LANGUAGE Foo #-}+#endif+main = undefined+EXIT 1+OUTPUT+tests/cpp-ext-enable.hs:1:1: Error: Parse error: tests/cpp-ext-enable.hs:3:14: error: [GHC-46537]+    Unsupported extension: Foo+Found:+  {-# LANGUAGE CPP #-}++  {-# LANGUAGE Foo #-}++  main = undefined++1 error++---------------------------------------------------------------------+RUN tests/cpp-ext-disable.hs+FILE tests/cpp-ext-disable.hs+{-# LANGUAGE CPP #-}+#if defined(FOO)+{-# LANGUAGE Foo #-}+#endif+main = undefined+EXIT 1+OUTPUT+tests/cpp-ext-disable.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN --cpp-simple tests/cpp-simple.hs+FILE tests/cpp-simple.hs+#include "Any/File.h"++main = print "Hello"+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/cpp-file1.hs+FILE tests/cpp-file1.hs+import Network.Wai+#if MIN_VERSION_wai(2, 0, 0)+import Network.Wai.Internal+#endif+OUTPUT+No hints++---------------------------------------------------------------------+RUN --cpp-file=tests/cabal_macros.h tests/cpp-file2.hs+FILE tests/cabal_macros.h+#define MIN_VERSION_wai(a,b,c) 1+FILE tests/cpp-file2.hs+import Network.Wai+#if MIN_VERSION_wai(2, 0, 0)+import Network.Wai.Internal+#endif+foo = map f . map g+OUTPUT+tests/cpp-file2.hs:5:7-19: Suggestion: Use map once+Found:+  map f . map g+Perhaps:+  map (f . g)++1 hint++---------------------------------------------------------------------+RUN --cpp-simple tests/cpp-file3.hs+FILE tests/cpp-file3.hs+import Network.Wai+#if MIN_VERSION_wai(2, 0, 0)+import Network.Wai.Internal+#endif+OUTPUT+No hints++---------------------------------------------------------------------+RUN --cpp-simple tests/cpp-file4.hs+FILE tests/cpp-file4.hs+import Network.Wai+#if defined(MIN_VERSION_wai) && MIN_VERSION_wai(2, 0, 0)+import Network.Wai.Internal+#endif+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/cpp-file5.hs+FILE tests/cpp-file5.hs+{-# LANGUAGE CPP #-}+main =+#if __GLASGOW_HASKELL__ > 800+  print __GLASGOW_HASKELL__+#else+  putStrLn $ show __GLASGOW_HASKELL__+#endif+OUTPUT+tests/cpp-file5.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN --cpp-define "__GLASGOW_HASKELL__=123" tests/cpp-file6.hs+FILE tests/cpp-file6.hs+{-# LANGUAGE CPP #-}+main =+#if __GLASGOW_HASKELL__ == 123+  print __GLASGOW_HASKELL__+#else+  putStrLn $ show __GLASGOW_HASKELL__+#endif+OUTPUT+tests/cpp-file6.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint
+ tests/cross.test view
@@ -0,0 +1,25 @@+---------------------------------------------------------------------+RUN tests/cross.hs1 tests/cross.hs2 --cross+FILE tests/cross.hs1++module B(bar) where+++bar = 1+    where+        a = 1+        b = 2+        c = 3++FILE tests/cross.hs2++module A(foo) where++foo = 1+    where+        a = 1+        b = 2+        c = 3++OUTPUT+No hints
+ tests/do-block.test view
@@ -0,0 +1,17 @@+---------------------------------------------------------------------+RUN tests/do-block.hs --hint=data/do-block.yaml+FILE tests/do-block.hs+h x = case f x of+  Just n -> g n+  Nothing -> Nothing+OUTPUT+tests/do-block.hs:(1,7)-(3,20): Warning: Redundant Nothing+Found:+  case f x of+    Just n -> g n+    Nothing -> Nothing+Perhaps:+  do n <- f x+     g n++1 hint
+ tests/find.test view
@@ -0,0 +1,42 @@+---------------------------------------------------------------------+RUN --find=tests/find.hs+FILE tests/find.hs+{-# LANGUAGE CPP, ExistentialQuantification, Rank2Types #-}++module Util where++import Control.Arrow+import Control.Monad.Trans.State+import Data.Char+import Data.Function++infixr 4 %^&, `wheeeee`++instance Foo a where+    bar = baz + qux++listM' :: Monad m => [a] -> m [a]+listM' x = length x `seq` return x++notNull = not . null++headDef :: a -> [a] -> a+headDef x [] = x+headDef x (y:ys) = y++isLeft Left{} = True; isLeft _ = False+isRight = not . isLeft++swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)++defaultExtensions = knownExtensions \\ badExtensions+OUTPUT+# hints found in tests/find.hs+- fixity: "infixr 4 %^&"+- fixity: "infixr 4 `wheeeee`"+- warn: {lhs: "baz + qux", rhs: "bar"}+- warn: {lhs: "length a `seq` return a", rhs: "listM' a"}+- warn: {lhs: "not (null a)", rhs: "notNull a"}+- warn: {lhs: "not (isLeft a)", rhs: "isRight a"}+- warn: {lhs: "knownExtensions \\\\ badExtensions", rhs: "defaultExtensions"}
+ tests/flag-extension.test view
@@ -0,0 +1,31 @@+---------------------------------------------------------------------+RUN tests/directory+FILE tests/directory/File1.hs+ foo = map f . map g+FILE tests/directory/File2.lhs+> foo = map f . map g+OUTPUT+tests/directory/File1.hs:1:8-20: Suggestion: Use map once+Found:+  map f . map g+Perhaps:+  map (f . g)++tests/directory/File2.lhs:1:9-21: Suggestion: Use map once+Found:+  map f . map g+Perhaps:+  map (f . g)++2 hints++---------------------------------------------------------------------+RUN tests/directory --extension=lhs+OUTPUT+tests/directory/File2.lhs:1:9-21: Suggestion: Use map once+Found:+  map f . map g+Perhaps:+  map (f . g)++1 hint
+ tests/flag-ignore-suggestions.test view
@@ -0,0 +1,38 @@+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-1.hs --ignore-suggestions+FILE tests/flag-ignore-suggestions-1.hs+main = map f $ map g xs+OUTPUT+No hints++EXIT 0+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-2.hs --ignore-suggestions+FILE tests/flag-ignore-suggestions-2.hs+foo = (+1)+bar x = foo x+main = map f $ map g xs+OUTPUT+tests/flag-ignore-suggestions-2.hs:2:1-13: Warning: Eta reduce+Found:+  bar x = foo x+Perhaps:+  bar = foo++1 hint++EXIT 1+---------------------------------------------------------------------+RUN tests/flag-ignore-suggestions-3.hs --ignore-suggestions --show+FILE tests/flag-ignore-suggestions-3.hs+main = map f $ map g xs+OUTPUT+tests/flag-ignore-suggestions-3.hs:1:8-23: Suggestion: Use map once+Found:+  map f $ map g xs+Perhaps:+  map (f . g) xs++1 hint++EXIT 1
+ tests/flag-no-summary.test view
@@ -0,0 +1,18 @@+---------------------------------------------------------------------+RUN tests/flag-no-summary1.hs --no-summary+FILE tests/flag-no-summary1.hs+main = map f $ map g xs+OUTPUT+tests/flag-no-summary1.hs:1:8-23: Suggestion: Use map once+Found:+  map f $ map g xs+Perhaps:+  map (f . g) xs++EXIT 1+---------------------------------------------------------------------+RUN tests/flag-no-summary2.hs --no-summary+FILE tests/flag-no-summary2.hs+main = pure ()+OUTPUT+EXIT 0
+ tests/flag-only.test view
@@ -0,0 +1,30 @@+---------------------------------------------------------------------+RUN tests/flag-only-one-arg.hs --only="Redundant bracket"+FILE tests/flag-only-one-arg.hs+foo xs = if length xs == 0 then 42 else (666) -- should result in 2 suggestions+OUTPUT+tests/flag-only-one-arg.hs:1:41-45: Warning: Redundant bracket+Found:+  (666)+Perhaps:+  666++1 hint+---------------------------------------------------------------------+RUN tests/flag-only-many-args.hs --only="Redundant bracket" --only="Use ++"+FILE tests/flag-only-many-args.hs+foo xs = if length xs == 0 then concat ["foo", "bar"] else (666) -- should result in 3 suggestions+OUTPUT+tests/flag-only-many-args.hs:1:33-53: Suggestion: Use +++Found:+  concat ["foo", "bar"]+Perhaps:+  "foo" ++ "bar"++tests/flag-only-many-args.hs:1:60-64: Warning: Redundant bracket+Found:+  (666)+Perhaps:+  666++2 hints
+ tests/flag-quiet.test view
@@ -0,0 +1,6 @@+---------------------------------------------------------------------+RUN tests/flag-quiet.hs --quiet+FILE tests/flag-quiet.hs+main = map f $ map g xs+OUTPUT+EXIT 1
+ tests/flag-with-group.test view
@@ -0,0 +1,22 @@+---------------------------------------------------------------------+FILE tests/flag-with-group.hs+foo = map (+1) . maybe mempty reverse+RUN "--with-group=generalise" tests/flag-with-group.hs+OUTPUT+tests/flag-with-group.hs:1:7-9: Warning: Use fmap+Found:+  map+Perhaps:+  fmap++1 hint+---------------------------------------------------------------------+RUN "--with-group=generalise-for-conciseness" tests/flag-with-group.hs+OUTPUT+tests/flag-with-group.hs:1:18-29: Warning: Use foldMap+Found:+  maybe mempty+Perhaps:+  foldMap++1 hint
+ tests/hint.test view
@@ -0,0 +1,241 @@+---------------------------------------------------------------------+RUN tests/newtype-derive.hs --hint=data/hlint.yaml+FILE tests/newtype-derive.hs+{-# LANGUAGE DeriveTraversable #-} -- Implies DeriveFoldable and DeriveFunctor+{-# LANGUAGE DeriveDataTypeable #-}+module Test(A) where++import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+import Data.Typeable (Typeable)++newtype A f = A f+  deriving (Foldable, Functor, Traversable, Typeable)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/note.hs+FILE tests/note.hs+{-# LANGUAGE RecordWildCards #-}++module Sample(test) where++test xs = length xs == 0+OUTPUT+tests/note.hs:1:1-32: Warning: Unused LANGUAGE pragma+Found:+  {-# LANGUAGE RecordWildCards #-}+Perhaps you should remove it.+Note: may require `{-# LANGUAGE DisambiguateRecordFields #-}` adding to the top of the file++tests/note.hs:5:11-24: Suggestion: Use null+Found:+  length xs == 0+Perhaps:+  null xs+Note: increases laziness++2 hints++---------------------------------------------------------------------+RUN tests/brackets.hs+FILE tests/brackets.hs+test = if isNothing x then (-1.0) else fromJust x+OUTPUT+tests/brackets.hs:1:8-49: Warning: Use fromMaybe+Found:+  if isNothing x then (- 1.0) else fromJust x+Perhaps:+  fromMaybe (- 1.0) x++1 hint++---------------------------------------------------------------------+RUN tests/typesig-ignore.hs+FILE tests/typesig-ignore.hs+-- Bug #563+module Foo(foobar) where+{-# ANN foobar "HLint: ignore Use String" #-}++foobar :: [Char]+foobar = []+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/typesig-ignore2.hs+FILE tests/typesig-ignore2.hs+-- Bug #563+module Foo(foobar) where+{-# HLINT ignore foobar "Use String" #-}++foobar :: [Char]+foobar = []+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-module.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-module.lhs+> import Restricted.Module+OUTPUT+tests/restricted-module.lhs:1:3-26: Warning: Avoid restricted module+Found:+  import Restricted.Module+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-module-message.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-module-message.lhs+> import Restricted.Module.Message+OUTPUT+tests/restricted-module-message.lhs:1:3-34: Warning: Avoid restricted module+Found:+  import Restricted.Module.Message+Note: Custom message++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-bad.lhs+> import Restricted.Module.BadIdents (bad)+OUTPUT+tests/restricted-badidents-bad.lhs:1:3-42: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.BadIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-multibad.lhs+> import Restricted.Module.BadIdents (bad, good)+OUTPUT+tests/restricted-badidents-multibad.lhs:1:3-48: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.BadIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-valid.lhs+> import Restricted.Module.BadIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-badidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-universal.lhs+> import Restricted.Module.BadIdents+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-bad.lhs+> import Restricted.Module.OnlyIdents (bad)+OUTPUT+tests/restricted-onlyidents-bad.lhs:1:3-43: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.OnlyIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-multibad.lhs+> import Restricted.Module.OnlyIdents (bad, good)+OUTPUT+tests/restricted-onlyidents-multibad.lhs:1:3-49: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.OnlyIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-valid.lhs+> import Restricted.Module.OnlyIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-universal.lhs+> import Restricted.Module.OnlyIdents+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-function.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-function.lhs+> main = restricted ()+OUTPUT+tests/restricted-function.lhs:1:10-19: Warning: Avoid restricted function+Found:+  restricted+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-function-message.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-function-message.lhs+> main = restrictedMessage ()+OUTPUT+tests/restricted-function-message.lhs:1:10-26: Warning: Avoid restricted function+Found:+  restrictedMessage+Note: Custom message++1 hint++---------------------------------------------------------------------+RUN tests/restricted-extension.hs --hint=data/test-restrict.yaml+FILE tests/restricted-extension.hs+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Test(A) where++import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+import Data.Typeable (Typeable)++newtype A f = A f+  deriving (Foldable, Functor, Traversable, Typeable)+OUTPUT+OUTPUT+tests/restricted-extension.hs:1:1-31: Warning: Unused LANGUAGE pragma+Found:+  {-# LANGUAGE DeriveFoldable #-}+Perhaps you should remove it.+Note: Extension DeriveFoldable is implied by DeriveTraversable++tests/restricted-extension.hs:2:1-30: Warning: Unused LANGUAGE pragma+Found:+  {-# LANGUAGE DeriveFunctor #-}+Perhaps you should remove it.+Note: Extension DeriveFunctor is implied by DeriveTraversable++tests/restricted-extension.hs:2:1-30: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE DeriveFunctor #-}+Note: may break the code++tests/restricted-extension.hs:3:1-34: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE DeriveTraversable #-}+Note: Custom message++4 hints
+ tests/hintrule-implies-classify.test view
@@ -0,0 +1,12 @@+---------------------------------------------------------------------+RUN tests/hintrule-implies-classify.hs --hint=data/hintrule-implies-classify.yaml+FILE tests/hintrule-implies-classify.hs+x = mapM print [1, 2, 3]+OUTPUT+tests/hintrule-implies-classify.hs:1:5-8: Warning: Use traverse+Found:+  mapM+Perhaps:+  traverse++1 hint
+ tests/import_style.test view
@@ -0,0 +1,129 @@+---------------------------------------------------------------------+RUN tests/importStyle-1.hs --hint=data/import_style.yaml+FILE tests/importStyle-1.hs+import HypotheticalModule1+import HypotheticalModule2+import HypotheticalModule3+import qualified HypotheticalModule3.SomeModule+import HypotheticalModule3.SomeModule qualified+import qualified HypotheticalModule3.OtherSubModule+OUTPUT+tests/importStyle-1.hs:1:1-26: Warning: Avoid restricted alias+Found:+  import HypotheticalModule1+Perhaps:+  import HypotheticalModule1 as HM1+Note: may break the code++tests/importStyle-1.hs:2:1-26: Warning: HypotheticalModule2 should be imported qualified or with an explicit import list+Found:+  import HypotheticalModule2+Perhaps:+  import qualified HypotheticalModule2+Note: may break the code++tests/importStyle-1.hs:3:1-26: Warning: HypotheticalModule3 should be imported qualified+Found:+  import HypotheticalModule3+Perhaps:+  import qualified HypotheticalModule3+Note: may break the code++tests/importStyle-1.hs:4:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+  import qualified HypotheticalModule3.SomeModule+Perhaps:+  import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:5:1-47: Warning: HypotheticalModule3.SomeModule should be imported unqualified+Found:+  import HypotheticalModule3.SomeModule qualified+Perhaps:+  import HypotheticalModule3.SomeModule+Note: may break the code++tests/importStyle-1.hs:6:1-51: Warning: HypotheticalModule3.OtherSubModule should be imported post-qualified or unqualified+Found:+  import qualified HypotheticalModule3.OtherSubModule+Perhaps:+  import HypotheticalModule3.OtherSubModule qualified+Note: may break the code++6 hints++---------------------------------------------------------------------+RUN tests/importStyle-2.hs --hint=data/import_style.yaml+FILE tests/importStyle-2.hs+import HypotheticalModule1 as HM1+import qualified HypotheticalModule2+import HypotheticalModule2 (a, b, c, d)+import qualified HypotheticalModule3+import HypotheticalModule3.SomeModule+import HypotheticalModule3.OtherSubModule qualified+import HypotheticalModule3.OtherSubModule+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/importStyle-postqual-pos.hs --hint=data/import_style.yaml -XImportQualifiedPost+FILE tests/importStyle-postqual-pos.hs+import HypotheticalModule1 qualified as HM1+import HypotheticalModule2 qualified+import HypotheticalModule2 qualified as Arbitrary+import HypotheticalModule3 qualified+import HypotheticalModule3 qualified as Arbitrary+import HypotheticalModule4 qualified as HM4+import HypotheticalModule5 qualified+import HypotheticalModule5 qualified as HM5+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/importStyle-postqual-neg.hs --hint=data/import_style.yaml -XImportQualifiedPost+FILE tests/importStyle-postqual-neg.hs+import HypotheticalModule1 qualified+import qualified HypotheticalModule4+import qualified HypotheticalModule4 as Verbotten+import qualified HypotheticalModule4 as HM4+import HypotheticalModule5 as HM5+import qualified HypotheticalModule5++OUTPUT+tests/importStyle-postqual-neg.hs:1:1-36: Warning: Avoid restricted alias+Found:+  import HypotheticalModule1 qualified+Perhaps:+  import HypotheticalModule1 qualified as HM1+Note: may break the code++tests/importStyle-postqual-neg.hs:2:1-36: Warning: Avoid restricted alias+Found:+  import qualified HypotheticalModule4+Perhaps:+  import qualified HypotheticalModule4 as HM4+Note: may break the code++tests/importStyle-postqual-neg.hs:3:1-49: Warning: Avoid restricted alias+Found:+  import qualified HypotheticalModule4 as Verbotten+Perhaps:+  import qualified HypotheticalModule4 as HM4+Note: may break the code++tests/importStyle-postqual-neg.hs:5:1-33: Warning: HypotheticalModule5 should be imported post-qualified+Found:+  import HypotheticalModule5 as HM5+Perhaps:+  import HypotheticalModule5 qualified as HM5+Note: may break the code++tests/importStyle-postqual-neg.hs:6:1-36: Warning: HypotheticalModule5 should be imported post-qualified+Found:+  import qualified HypotheticalModule5+Perhaps:+  import HypotheticalModule5 qualified+Note: may break the code++5 hints+---------------------------------------------------------------------
+ tests/json.test view
@@ -0,0 +1,40 @@+---------------------------------------------------------------------+RUN tests/json-none.hs --json+FILE tests/json-none.hs+foo = (+1)+OUTPUT+[]++---------------------------------------------------------------------+RUN tests/json-one.hs --json+FILE tests/json-one.hs+foo = (+1)+bar x = foo x+OUTPUT+[{"module":["Main"],"decl":["bar"],"severity":"Warning","hint":"Eta reduce","file":"tests/json-one.hs","startLine":2,"startColumn":1,"endLine":2,"endColumn":14,"from":"bar x = foo x","to":"bar = foo","note":[],"refactorings":"[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [(\"body\",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = \"bar = body\"}]"}]++---------------------------------------------------------------------+RUN tests/json-two.hs --json+FILE tests/json-two.hs+foo = (+1)+bar x = foo x+baz = getLine >>= pure . upper+OUTPUT+[{"module":["Main"],"decl":["bar"],"severity":"Warning","hint":"Eta reduce","file":"tests/json-two.hs","startLine":2,"startColumn":1,"endLine":2,"endColumn":14,"from":"bar x = foo x","to":"bar = foo","note":[],"refactorings":"[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [(\"body\",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = \"bar = body\"}]"}+,{"module":["Main"],"decl":["baz"],"severity":"Suggestion","hint":"Use <&>","file":"tests/json-two.hs","startLine":3,"startColumn":7,"endLine":3,"endColumn":31,"from":"getLine >>= pure . upper","to":"getLine Data.Functor.<&> upper","note":[],"refactorings":"[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 31}, subts = [(\"f\",SrcSpan {startLine = 3, startCol = 26, endLine = 3, endCol = 31}),(\"m\",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = \"m Data.Functor.<&> f\"}]"}]++---------------------------------------------------------------------+RUN tests/json-parse-error.hs --json+FILE tests/json-parse-error.hs+@+OUTPUT+[{"module":[],"decl":[],"severity":"Error","hint":"Parse error: on input `@'","file":"tests/json-parse-error.hs","startLine":1,"startColumn":1,"endLine":1,"endColumn":2,"from":"> @\n","to":null,"note":[],"refactorings":"[]"}]++---------------------------------------------------------------------+RUN tests/json-note.hs --json+FILE tests/json-note.hs+foo = any (a ==)+bar = foldl (&&) True+OUTPUT+[{"module":["Main"],"decl":["foo"],"severity":"Warning","hint":"Use elem","file":"tests/json-note.hs","startLine":1,"startColumn":7,"endLine":1,"endColumn":17,"from":"any (a ==)","to":"elem a","note":["requires a valid `Eq` instance for `a`"],"refactorings":"[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 17}, subts = [(\"a\",SrcSpan {startLine = 1, startCol = 12, endLine = 1, endCol = 13})], orig = \"elem a\"}]"}+,{"module":["Main"],"decl":["bar"],"severity":"Warning","hint":"Use and","file":"tests/json-note.hs","startLine":2,"startColumn":7,"endLine":2,"endColumn":22,"from":"foldl (&&) True","to":"and","note":["increases laziness"],"refactorings":"[Replace {rtype = Expr, pos = SrcSpan {startLine = 2, startCol = 7, endLine = 2, endCol = 22}, subts = [], orig = \"and\"}]"}]
+ tests/lhs.test view
@@ -0,0 +1,47 @@+---------------------------------------------------------------------+RUN tests/lhs-line-numbers.lhs+FILE tests/lhs-line-numbers.lhs+BUG 331++> main = print ([1] ++ [2, 3])+OUTPUT+tests/lhs-line-numbers.lhs:3:17-29: Suggestion: Use :+Found:+  [1] ++ [2, 3]+Perhaps:+  1 : [2, 3]++1 hint++---------------------------------------------------------------------+RUN tests/lhs-line-numbers2.lhs+FILE tests/lhs-line-numbers2.lhs+BUG 331+%  Blah1+%  Blah2+%  Blah3++\begin{code}+module+\end{code}+OUTPUT+tests/lhs-line-numbers2.lhs:10:1: Error: Parse error: possibly incorrect indentation or mismatched brackets+Found:+    \end{code}++  >++1 error++---------------------------------------------------------------------+RUN tests/lhs-first-line.lhs+FILE tests/lhs-first-line.lhs+> main = print ([1] ++ [2, 3])+OUTPUT+tests/lhs-first-line.lhs:1:17-29: Suggestion: Use :+Found:+  [1] ++ [2, 3]+Perhaps:+  1 : [2, 3]++1 hint
+ tests/no_explicit_cpp.test view
@@ -0,0 +1,17 @@+---------------------------------------------------------------------+RUN tests/NoExplicitCpp.hs -XHaskell2010+FILE tests/NoExplicitCpp.hs+-- We expect C-preprocessing despite `CPP` not being in the+-- enabled extensions implied by the command line. See issue+-- https://github.com/ndmitchell/hlint/issues/1360.+{-# LANGUAGE CPP #-}+#if 1+hlint = __HLINT__+#endif+OUTPUT+tests/NoExplicitCpp.hs:4:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint
+ tests/parse-error.test view
@@ -0,0 +1,33 @@+---------------------------------------------------------------------+RUN "--ignore=Parse error" tests/ignore-parse-error.hs+FILE tests/ignore-parse-error.hs+where+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/ignore-parse-error2.hs+FILE tests/ignore-parse-error2.hs+module Foo where++where+OUTPUT+tests/ignore-parse-error2.hs:3:1-5: Error: Parse error: on input `where'+Found:+    module Foo where++  > where++1 error++---------------------------------------------------------------------+RUN tests/ignore-parse-error3.hs+FILE tests/ignore-parse-error3.hs+{-# LANGUAGE InvalidExtension #-}+OUTPUT+tests/ignore-parse-error3.hs:1:1: Error: Parse error: tests/ignore-parse-error3.hs:1:14: error: [GHC-46537]+    Unsupported extension: InvalidExtension+Found:+  {-# LANGUAGE InvalidExtension #-}++1 error
+ tests/sarif.test view
@@ -0,0 +1,38 @@+---------------------------------------------------------------------+RUN tests/sarif-none.hs --sarif+FILE tests/sarif-none.hs+foo = (+1)+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[]}]}++---------------------------------------------------------------------+RUN tests/sarif-one.hs --sarif+FILE tests/sarif-one.hs+foo = (+1)+bar x = foo x+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-one.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-one.hs"},"region":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Eta reduce"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-one.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14},"insertedContent":{"text":"bar = foo"}}]}]}],"ruleId":"Eta reduce"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-two.hs --sarif+FILE tests/sarif-two.hs+foo = (+1)+bar x = foo x+baz = getLine >>= pure . upper+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-two.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-two.hs"},"region":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Eta reduce"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-two.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":1,"endLine":2,"endColumn":14},"insertedContent":{"text":"bar = foo"}}]}]}],"ruleId":"Eta reduce"},{"message":{"text":"tests/sarif-two.hs:3:7-30: Suggestion: Use <&>\nFound:\n  getLine >>= pure . upper\nPerhaps:\n  getLine Data.Functor.<&> upper\n"},"level":"note","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-two.hs"},"region":{"startLine":3,"startColumn":7,"endLine":3,"endColumn":31}},"logicalLocations":[{"name":"baz","fullyQualifiedName":"Main.baz"}]}],"fixes":[{"description":{"text":"Use <&>"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-two.hs"},"replacements":[{"deletedRegion":{"startLine":3,"startColumn":7,"endLine":3,"endColumn":31},"insertedContent":{"text":"getLine Data.Functor.<&> upper"}}]}]}],"ruleId":"Use <&>"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-parse-error.hs --sarif+FILE tests/sarif-parse-error.hs+@+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-parse-error.hs:1:1: Error: Parse error: on input `@'\nFound:\n  > @\n"},"level":"error","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-parse-error.hs"},"region":{"startLine":1,"startColumn":1,"endLine":1,"endColumn":2}}}],"fixes":[{"description":{"text":"Parse error: on input `@'"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-parse-error.hs"},"replacements":[{"deletedRegion":{"startLine":1,"startColumn":1,"endLine":1,"endColumn":2}}]}]}],"ruleId":"Parse error: on input `@'"}]}]}++---------------------------------------------------------------------+RUN tests/sarif-note.hs --sarif+FILE tests/sarif-note.hs+foo = any (a ==)+bar = foldl (&&) True+OUTPUT+{"version":"2.1.0","$schema":"https://raw.githubusercontent.com/oasis-tcs/sarif-spec/master/Schemata/sarif-schema-2.1.0.json","runs":[{"tool":{"driver":{"name":"hlint","version":"__VERSION__","informationUri":"https://github.com/ndmitchell/hlint"}},"results":[{"message":{"text":"tests/sarif-note.hs:1:7-16: Warning: Use elem\nFound:\n  any (a ==)\nPerhaps:\n  elem a\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-note.hs"},"region":{"startLine":1,"startColumn":7,"endLine":1,"endColumn":17}},"logicalLocations":[{"name":"foo","fullyQualifiedName":"Main.foo"}]}],"fixes":[{"description":{"text":"Use elem"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-note.hs"},"replacements":[{"deletedRegion":{"startLine":1,"startColumn":7,"endLine":1,"endColumn":17},"insertedContent":{"text":"elem a"}}]}]}],"ruleId":"Use elem"},{"message":{"text":"tests/sarif-note.hs:2:7-21: Warning: Use and\nFound:\n  foldl (&&) True\nPerhaps:\n  and\nNote: increases laziness\n"},"level":"warning","locations":[{"physicalLocation":{"artifactLocation":{"uri":"tests/sarif-note.hs"},"region":{"startLine":2,"startColumn":7,"endLine":2,"endColumn":22}},"logicalLocations":[{"name":"bar","fullyQualifiedName":"Main.bar"}]}],"fixes":[{"description":{"text":"Use and"},"artifactChanges":[{"artifactLocation":{"uri":"tests/sarif-note.hs"},"replacements":[{"deletedRegion":{"startLine":2,"startColumn":7,"endLine":2,"endColumn":22},"insertedContent":{"text":"and"}}]}]}],"ruleId":"Use and"}]}]}
+ tests/serialise.test view
@@ -0,0 +1,85 @@+---------------------------------------------------------------------+RUN tests/serialise-none.hs --serialise+FILE tests/serialise-none.hs+foo = (+1)+OUTPUT+[]++---------------------------------------------------------------------+RUN tests/serialise-one.hs --serialise+FILE tests/serialise-one.hs+foo = (+1)+bar x = foo x+OUTPUT+[("tests/serialise-one.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [("body",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = "bar = body"}])]++---------------------------------------------------------------------+RUN tests/serialise-two.hs --serialise+FILE tests/serialise-two.hs+foo = (+1)+bar x = foo x+baz = getLine >>= pure . upper+OUTPUT+[("tests/serialise-two.hs:2:1-13: Warning: Eta reduce\nFound:\n  bar x = foo x\nPerhaps:\n  bar = foo\n",[Replace {rtype = Decl, pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 14}, subts = [("body",SrcSpan {startLine = 2, startCol = 9, endLine = 2, endCol = 12})], orig = "bar = body"}]),("tests/serialise-two.hs:3:7-30: Suggestion: Use <&>\nFound:\n  getLine >>= pure . upper\nPerhaps:\n  getLine Data.Functor.<&> upper\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 31}, subts = [("f",SrcSpan {startLine = 3, startCol = 26, endLine = 3, endCol = 31}),("m",SrcSpan {startLine = 3, startCol = 7, endLine = 3, endCol = 14})], orig = "m Data.Functor.<&> f"}])]+++---------------------------------------------------------------------+RUN tests/serialise-three.hs --serialise+FILE tests/serialise-three.hs+foo = concat (map f (let x = x in x))+OUTPUT+[("tests/serialise-three.hs:1:7-37: Warning: Use concatMap\nFound:\n  concat (map f (let x = x in x))\nPerhaps:\n  concatMap f (let x = x in x)\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 38}, subts = [("f",SrcSpan {startLine = 1, startCol = 19, endLine = 1, endCol = 20}),("x",SrcSpan {startLine = 1, startCol = 21, endLine = 1, endCol = 37})], orig = "concatMap f x"}])]+++---------------------------------------------------------------------+RUN tests/serialise-four.hs --serialise --hint=data/hlint.yaml+FILE tests/serialise-four.hs+{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+OUTPUT+[("tests/serialise-four.hs:2:1-20: Warning: Use fewer LANGUAGE pragmas\nFound:\n  {-# LANGUAGE CPP #-}\n  {-# LANGUAGE CPP #-}\nPerhaps:\n  {-# LANGUAGE CPP #-}\n",[ModifyComment {pos = SrcSpan {startLine = 2, startCol = 1, endLine = 2, endCol = 21}, newComment = "{-# LANGUAGE CPP #-}"},ModifyComment {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 21}, newComment = ""}])]+++---------------------------------------------------------------------+RUN tests/serialise-five.hs --serialise+FILE tests/serialise-five.hs+import qualified GHC as GHC+OUTPUT+[("tests/serialise-five.hs:1:1-27: Suggestion: Redundant as\nFound:\n  import qualified GHC as GHC\nPerhaps:\n  import qualified GHC\n",[RemoveAsKeyword {pos = SrcSpan {startLine = 1, startCol = 1, endLine = 1, endCol = 28}}])]+++---------------------------------------------------------------------+RUN tests/serialise-six.hs --serialise+FILE tests/serialise-six.hs+foo = qux (\x -> f (g x))+OUTPUT+[("tests/serialise-six.hs:1:12-24: Suggestion: Avoid lambda\nFound:\n  / x -> f (g x)\nPerhaps:\n  f . g\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 1, startCol = 12, endLine = 1, endCol = 25}, subts = [("a",SrcSpan {startLine = 1, startCol = 18, endLine = 1, endCol = 19}),("b",SrcSpan {startLine = 1, startCol = 21, endLine = 1, endCol = 22})], orig = "a . b"}])]+++---------------------------------------------------------------------+RUN tests/serialise-seven.hs --serialise+FILE tests/serialise-seven.hs+foo = if baz+        then qux+        else if baz'+             then qux'+             else qux''+OUTPUT+[("tests/serialise-seven.hs:(1,1)-(5,23): Suggestion: Use guards\nFound:\n  foo = if baz then qux else if baz' then qux' else qux''\nPerhaps:\n  foo\n    | baz = qux\n    | baz' = qux'\n    | otherwise = qux''\n",[Replace {rtype = Match, pos = SrcSpan {startLine = 1, startCol = 1, endLine = 5, endCol = 24}, subts = [("g1001",SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 13}),("g1002",SrcSpan {startLine = 3, startCol = 17, endLine = 3, endCol = 21}),("e1001",SrcSpan {startLine = 2, startCol = 14, endLine = 2, endCol = 17}),("e1002",SrcSpan {startLine = 4, startCol = 19, endLine = 4, endCol = 23}),("e1003",SrcSpan {startLine = 5, startCol = 19, endLine = 5, endCol = 24})], orig = "foo\n  | g1001 = e1001\n  | g1002 = e1002\n  | otherwise = e1003"}])]+++---------------------------------------------------------------------+RUN tests/serialise-eight.hs --serialise+FILE tests/serialise-eight.hs+foo = do x <- baz+         x+OUTPUT+[("tests/serialise-eight.hs:(1,7)-(2,10): Warning: Use join\nFound:\n  do x <- baz\n     x\nPerhaps:\n  do join baz\n",[Replace {rtype = Stmt, pos = SrcSpan {startLine = 1, startCol = 10, endLine = 1, endCol = 18}, subts = [("x",SrcSpan {startLine = 1, startCol = 15, endLine = 1, endCol = 18})], orig = "join x"},Delete {rtype = Stmt, pos = SrcSpan {startLine = 2, startCol = 10, endLine = 2, endCol = 11}}])]+++---------------------------------------------------------------------+RUN tests/serialise-nine.hs --serialise+FILE tests/serialise-nine.hs+foo | True = baz+OUTPUT+[("tests/serialise-nine.hs:1:1-16: Suggestion: Redundant guard\nFound:\n  foo | True = baz\nPerhaps:\n  foo = baz\n",[Delete {rtype = Stmt, pos = SrcSpan {startLine = 1, startCol = 7, endLine = 1, endCol = 11}}])]
+ tests/wildcards.test view
@@ -0,0 +1,816 @@+----+RUN tests/wildcards-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-a.hs+import A as Z+OUTPUT+tests/wildcards-a.hs:1:1-13: Warning: Avoid restricted alias+Found:+  import A as Z+Perhaps:+  import A as A+Note: may break the code++1 hint++----+RUN tests/wildcards-xa.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xa.hs+import XA as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-a.hs+import X.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-a.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-a.hs+import X.Y.A as Z+OUTPUT+No hints++----+RUN tests/wildcards-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-b.hs+import B as Z+OUTPUT+tests/wildcards-b.hs:1:1-13: Warning: Avoid restricted alias+Found:+  import B as Z+Perhaps:+  import B as B+Note: may break the code++1 hint++----+RUN tests/wildcards-xb.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xb.hs+import XB as Z+OUTPUT+tests/wildcards-xb.hs:1:1-14: Warning: Avoid restricted alias+Found:+  import XB as Z+Perhaps:+  import XB as B+Note: may break the code++1 hint++----+RUN tests/wildcards-x-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-b.hs+import X.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-y-b.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-b.hs+import X.Y.B as Z+OUTPUT+No hints++----+RUN tests/wildcards-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-c.hs+import C as Z+OUTPUT+tests/wildcards-c.hs:1:1-13: Warning: Avoid restricted alias+Found:+  import C as Z+Perhaps:+  import C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-xc.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xc.hs+import XC as Z+OUTPUT+No hints++----+RUN tests/wildcards-x-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-c.hs+import X.C as Z+OUTPUT+tests/wildcards-x-c.hs:1:1-15: Warning: Avoid restricted alias+Found:+  import X.C as Z+Perhaps:+  import X.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-c.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-c.hs+import X.Y.C as Z+OUTPUT+tests/wildcards-x-y-c.hs:1:1-17: Warning: Avoid restricted alias+Found:+  import X.Y.C as Z+Perhaps:+  import X.Y.C as C+Note: may break the code++1 hint++----+RUN tests/wildcards-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-d.hs+import D as Z+OUTPUT+tests/wildcards-d.hs:1:1-13: Warning: Avoid restricted alias+Found:+  import D as Z+Perhaps:+  import D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-xd.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xd.hs+import XD as Z+OUTPUT+tests/wildcards-xd.hs:1:1-14: Warning: Avoid restricted alias+Found:+  import XD as Z+Perhaps:+  import XD as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-d.hs+import X.D as Z+OUTPUT+tests/wildcards-x-d.hs:1:1-15: Warning: Avoid restricted alias+Found:+  import X.D as Z+Perhaps:+  import X.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-d.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-d.hs+import X.Y.D as Z+OUTPUT+tests/wildcards-x-y-d.hs:1:1-17: Warning: Avoid restricted alias+Found:+  import X.Y.D as Z+Perhaps:+  import X.Y.D as D+Note: may break the code++1 hint++----+RUN tests/wildcards-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-e.hs+module E where import E+OUTPUT+No hints++----+RUN tests/wildcards-xe.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xe.hs+module XE where import E+OUTPUT+tests/wildcards-xe.hs:1:17-24: Warning: Avoid restricted module+Found:+  import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-e.hs+module X.E where import E+OUTPUT+tests/wildcards-x-e.hs:1:18-25: Warning: Avoid restricted module+Found:+  import E+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-e.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-e.hs+module X.Y.E where import E+OUTPUT+tests/wildcards-x-y-e.hs:1:20-27: Warning: Avoid restricted module+Found:+  import E+Note: may break the code++1 hint++----+RUN tests/wildcards-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-f.hs+module F where import F+OUTPUT+No hints++----+RUN tests/wildcards-xf.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xf.hs+module XF where import F+OUTPUT+No hints++----+RUN tests/wildcards-x-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-f.hs+module X.F where import F+OUTPUT+tests/wildcards-x-f.hs:1:18-25: Warning: Avoid restricted module+Found:+  import F+Note: may break the code++1 hint++----+RUN tests/wildcards-x-y-f.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-f.hs+module X.Y.F where import F+OUTPUT+tests/wildcards-x-y-f.hs:1:20-27: Warning: Avoid restricted module+Found:+  import F+Note: may break the code++1 hint++----+RUN tests/wildcards-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-g.hs+module G where import G+OUTPUT+No hints++----+RUN tests/wildcards-xg.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xg.hs+module XG where import G+OUTPUT+tests/wildcards-xg.hs:1:17-24: Warning: Avoid restricted module+Found:+  import G+Note: may break the code++1 hint++----+RUN tests/wildcards-x-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-g.hs+module X.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-x-y-g.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-g.hs+module X.Y.G where import G+OUTPUT+No hints++----+RUN tests/wildcards-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-h.hs+module H where import H+OUTPUT+No hints++----+RUN tests/wildcards-xh.hs --hint=data/wildcards.yaml+FILE tests/wildcards-xh.hs+module XH where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-h.hs+module X.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-x-y-h.hs --hint=data/wildcards.yaml+FILE tests/wildcards-x-y-h.hs+module X.Y.H where import H+OUTPUT+No hints++----+RUN tests/wildcards-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-u.hs+module U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-xu.hs+module XU where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-u.hs+module X.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-module-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-x-y-u.hs+module X.Y.U where import U+OUTPUT+No hints++----+RUN tests/wildcards-import-xu.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-xu.hs+module U where import XU+OUTPUT+No hints++----+RUN tests/wildcards-import-x-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-u.hs+module U where import X.U+OUTPUT+No hints++----+RUN tests/wildcards-import-x-y-u.hs --hint=data/wildcards.yaml+FILE tests/wildcards-import-x-y-u.hs+module U where import X.Y.U+OUTPUT+No hints++----+RUN tests/wildcards-module-w.hs --hint=data/wildcards.yaml+FILE tests/wildcards-module-w.hs+module W where import U+OUTPUT+tests/wildcards-module-w.hs:1:16-23: Warning: Avoid restricted module+Found:+  import U+Note: may break the code++1 hint++----+RUN tests/wildcard-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-i.hs+module I where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xi.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xi.hs+module XI where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xi.hs:1:24-31: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-x-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-i.hs+module X.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-i.hs:1:25-32: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-x-y-i.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-i.hs+module X.Y.I where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-i.hs:1:27-34: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-j.hs+module J where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xj.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xj.hs+module XJ where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-j.hs+module X.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-j.hs:1:25-32: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-x-y-j.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-j.hs+module X.Y.J where x = y (\ _ -> z)+OUTPUT+tests/wildcard-x-y-j.hs:1:27-34: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-k.hs+module K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xk.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xk.hs+module XK where x = y (\ _ -> z)+OUTPUT+tests/wildcard-xk.hs:1:24-31: Suggestion: Use const+Found:+  \ _ -> z+Perhaps:+  const z++1 hint++----+RUN tests/wildcard-x-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-k.hs+module X.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-k.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-k.hs+module X.Y.K where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-l.hs+module L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-xl.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xl.hs+module XL where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-l.hs+module X.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-x-y-l.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-l.hs+module X.Y.L where x = y (\ _ -> z)+OUTPUT+No hints++----+RUN tests/wildcard-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-m.hs+{-# LANGUAGE CPP #-} module M where+OUTPUT+No hints++----+RUN tests/wildcard-xm.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xm.hs+{-# LANGUAGE CPP #-} module XM where+OUTPUT+tests/wildcard-xm.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-m.hs+{-# LANGUAGE CPP #-} module X.M where+OUTPUT+tests/wildcard-x-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-m.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-m.hs+{-# LANGUAGE CPP #-} module X.Y.M where+OUTPUT+tests/wildcard-x-y-m.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-n.hs+{-# LANGUAGE CPP #-} module N where+OUTPUT+No hints++----+RUN tests/wildcard-xn.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xn.hs+{-# LANGUAGE CPP #-} module XN where+OUTPUT+No hints++----+RUN tests/wildcard-x-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-n.hs+{-# LANGUAGE CPP #-} module X.N where+OUTPUT+tests/wildcard-x-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-n.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-n.hs+{-# LANGUAGE CPP #-} module X.Y.N where+OUTPUT+tests/wildcard-x-y-n.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-o.hs+{-# LANGUAGE CPP #-} module O where+OUTPUT+No hints++----+RUN tests/wildcard-xo.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xo.hs+{-# LANGUAGE CPP #-} module XO where+OUTPUT+tests/wildcard-xo.hs:1:1-20: Warning: Avoid restricted extensions+Found:+  {-# LANGUAGE CPP #-}+Note: may break the code++1 hint++----+RUN tests/wildcard-x-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-o.hs+{-# LANGUAGE CPP #-} module X.O where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-o.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-o.hs+{-# LANGUAGE CPP #-} module X.Y.O where+OUTPUT+No hints++----+RUN tests/wildcard-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-p.hs+{-# LANGUAGE CPP #-} module P where+OUTPUT+No hints++----+RUN tests/wildcard-xp.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xp.hs+{-# LANGUAGE CPP #-} module XP where+OUTPUT+No hints++----+RUN tests/wildcard-x-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-p.hs+{-# LANGUAGE CPP #-} module X.P where+OUTPUT+No hints++----+RUN tests/wildcard-x-y-p.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-p.hs+{-# LANGUAGE CPP #-} module X.Y.P where+OUTPUT+No hints++----+RUN tests/wildcard-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-q.hs+module Q where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xq.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xq.hs+module XQ where x = read ""+OUTPUT+tests/wildcard-xq.hs:1:21-24: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-q.hs+module X.Q where x = read ""+OUTPUT+tests/wildcard-x-q.hs:1:22-25: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-q.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-q.hs+module X.Y.Q where x = read ""+OUTPUT+tests/wildcard-x-y-q.hs:1:24-27: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-r.hs+module R where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xr.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xr.hs+module XR where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-r.hs+module X.R where x = read ""+OUTPUT+tests/wildcard-x-r.hs:1:22-25: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-y-r.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-r.hs+module X.Y.R where x = read ""+OUTPUT+tests/wildcard-x-y-r.hs:1:24-27: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-s.hs+module S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xs.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xs.hs+module XS where x = read ""+OUTPUT+tests/wildcard-xs.hs:1:21-24: Warning: Avoid restricted function+Found:+  read+Note: may break the code++1 hint++----+RUN tests/wildcard-x-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-s.hs+module X.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-s.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-s.hs+module X.Y.S where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-t.hs+module T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-xt.hs --hint=data/wildcards.yaml+FILE tests/wildcard-xt.hs+module XT where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-t.hs+module X.T where x = read ""+OUTPUT+No hints++----+RUN tests/wildcard-x-y-t.hs --hint=data/wildcards.yaml+FILE tests/wildcard-x-y-t.hs+module X.Y.T where x = read ""+OUTPUT+No hints