hlint-3.5/0000755000000000000000000000000007346545000010670 5ustar0000000000000000hlint-3.5/.hlint.yaml0000644000000000000000000000544007346545000012753 0ustar0000000000000000# 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: [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 - 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 meaingful argument names - ignore: {name: Use const, within: Config.Yaml} # TEMPORARY: this lint is deleted on HEAD - ignore: {name: Use String} hlint-3.5/CHANGES.txt0000644000000000000000000014766007346545000012517 0ustar0000000000000000Changelog for HLint (* = breaking change) 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 #681, fix for extensions on the command line not being used #686, suggest head (drop n x) ==> x !! max 0 n #683, add Use DerivingStrategies hint, ignored by default #685, skip running refactoring tool if there are no hints #675, warn about redundant fmaps on Eithers and Maybes Add back two $ hints removed in error 2.1.24, released 2019-06-10 Add Language.Haskell.HLint4 #658, ignore the previously undocumented {- LINT -} comments #658, force parsing of all pragmas and comments eagerly #665, make different fromMaybe hints have different names #664, better name for the Use uncurry hint #659, make hints with brackets at the root work 2.1.23, released 2019-06-09 Make it an error if your code does not parse with GHC #662, don't warn on ($x), since it might not really be TH #660, suggest tuple sections for \y -> (x,y) and similar #667, warn on return x >> m and similar #653, add symmetric versions of some == hints #650, add a group of teaching hints #651, warn on unused NamedFieldPuns #646, switch to an HTML doctype 2.1.22, released 2019-05-25 #634, suggest modifyIORef ==> writeIORef when applicable #642, suggest null in more places #640, reenable GHC parsing 2.1.21, released 2019-05-19 #637, temporary workaround for GHC parser segfaults 2.1.20, released 2019-05-15 * Fix a dumb break in the API on parseModuleEx 2.1.19, released 2019-05-14 * Revert PVP breakage 2.1.18, released 2019-05-13 * Change parseModuleEx/ParseError by accident #633, don't suggest changes inside RULES #631, suggest typeOf ==> typeRep Add matching on type variables #627, restrict to GHC 8.4 and above 2.1.17, released 2019-04-17 #626, add operator wildcards with ?, ??, ??? etc #625, fix an rnf/rhs typo #562, make test --verbose show a list of matched hints 2.1.16, released 2019-04-15 Make `seq` and `rem` hints apply to prefix functions #604, suggest rnf x `seq` () ==> rnf x #619, require haskell-src-exts-util-0.2.5 #619, fix move guards forward with record puns #618, add pure x <*> y ==> x <$> y #611, add == and subst for more advanced match conditions #612, add: Suggest f =<< instead of maybe Nothing f #609, add code smells #614, adds refactorings for camelCase and some list suggestions #605, make command line arguments override the .yaml file #603, QuasiQuotes can programatically use any extension 2.1.15, released 2019-02-27 #593, reorder guards in list comps where possible #597, suggest pushing a map over a list comp inside Say redundant pure, when the thing you are removing is pure #554, add more verbosity Don't test with GHC 7.4 to 7.8 #590, say which extensions should be deleted #591, be careful about encoding on stdin 2.1.14, released 2019-01-28 #587, fix extensions implied by ImplicitParams #588, suggest optional from attoparsec 2.1.13, released 2019-01-23 #583, suggest left sections to avoid lambdas #580, remove redundant LANGUAGE pragmas which are implied by others #575, add fixities for lattice #564, fix hint around withFile with AppendMode 2.1.12, released 2018-12-10 Require haskell-src-exts-1.21 2.1.11, released 2018-12-02 #553, define __HLINT__=1 for the C preprocessor #546, suggest `x $> y` for `const x <$> y`, `pure x <$> y`, and `return x <$> y` #546, suggest `x <$ y` for `x <&> const y`, `x <&> pure y`, and `x <&> return y` #556, disable a few incorrect lens hints #545, don't suggest turning type applications into sections #466, avoid false positives for Esqueleto #535, more lens hints Allow {-# HLINT #-} and {- HLINT -} pragmas #532, generate requested report files even if there are no hints #524, don't suggest newtype for existentials #521, add a hint for f x@_ = ... ==> f x = ... 2.1.10, released 2018-08-16 #516, don't require a .hlint.yaml when running tests Prefer .hlint.yaml to HLint.hs for settings #513, add section links in the HTML report 2.1.9, released 2018-08-08 Add QuickCheck fixities Warn on redundant EmptyCase extension 2.1.8, released 2018-07-06 #509, remove incorrect suggestions around sequence/pure 2.1.7, released 2018-07-03 #483, don't break quasi quotes when suggesting const #404, remove the "Unnecessary hiding" hint introduced in #338 #162, make avoiding lambda with `infix` give a different name #507, rename id x ==> x to redundant id #286, improve the duplicate pragma message #399, suggest (& f) ==> f #136, don't suggest eta-reducing runST #345, add catMaybes/fmap ==> mapMaybe #345, add foldMap id ==> fold #364, suggest >> instead of >>= \_ -> #502, DeriveTraversable implies DeriveFoldable and DeriveFunctor Add hints about fusing traverse/map Better names for mapM/map fusion hints and others #498, change the output to say "Perhaps:" rather than "Why not:" 2.1.6, released 2018-06-16 Match on explicit brackets at the root of a match expression #470, suggest TupleSections #496, suggest sequence/fmap ==> mapM #473, warn on redundant void, _ <- and return () Make use of <$> more general, but in simpler cases Warn about returns in the middle of do blocks #471, suggest readTVarIO #468, suggest using sortOn/Down #458, document the restriction feature #494, don't suggest newtype for unboxed tuples #488, avoid warning about more test prefixes 2.1.5, released 2018-05-05 #478, take account of deriving strategies for extension use #477, don't warn about unit_ as tasty-discover recommends it 2.1.4, released 2018-05-01 Don't warn about redundant $ for a $ b{c=d} 2.1.3, released 2018-04-18 Improve the performance of the camelCase hint Don't suggest camelCase for record fields Add a --timing flag to detect what is slow 2.1.2, released 2018-04-16 #407, don't error on unknown extensions on the command line Require extra-1.6.6 #464, add more hints for concatMap #462, ignore home directory when it isn't present 2.1.1, released 2018-03-24 #457, suggest turning on LambdaCase if necessary #457, add RequiresExtension note #454, add fixities for the HSpec `should*` functions #455, add some more sequence hints #453, allow pure in a few Monad hints as well as return #451, add --with-group command line option #424, suggest Foldable.forM_ in a few more places #445, add suggestions for reader/state monad #443, suggest join (x <$> y) ==> x =<< y 2.1, released 2018-02-07 * #433, make ideas span multiple modules/declarations #433, allow ignoring statement-level duplication hint #439, add more fixities for new base operators #437, --json output should be finite #425, avoid misparsing use of Gtk2Hs `on` function #353, detect unused results from for/traverse/sequenceA #428, add a few rules for the lens package #429, spot restricted functions in infix operators #427, don't eta reduce variables in the presence of quasi-quotes Improve the HTML slightly #416, add lens package fixities 2.0.15, released 2018-01-18 #426, don't suggest removing brackets for "x . (x +? x . x)" #426, better results with haskell-src-exts-util-0.2.2 2.0.14, released 2018-01-14 #376, apply the "use fmap" hint in fewer places #421, binaries available for OS X 2.0.13, released 2018-01-12 #376, suggest <$> instead of x <- foo; return $ f x #401, suggest removing brackets for (f . g) <$> x Add Semigroup instances 2.0.12, released 2017-12-12 Don't suggest Control.Arrow Upgrade to haskell-src-exts-1.20 2.0.11, released 2017-11-30 #411, parse the YAML file with lots of HSE extensions turned on #408, use the same config file logic in argsSettings as in hlint Don't use unexported type synonyms in the public API #405, fix false positives on MagicHash due to unboxed literals 2.0.10, released 2017-11-03 #377, suggest lambda case Add CodeClimate support #378, suggest map for degenerate foldr #395, suggest x $> y from x *> pure y and x *> return y #395, suggest x <$ y from pure x <* y and return x <* y #393, suggest f <$> m from m >>= pure . f and pure . f =<< #366, avoid the github API for prebuilt hlint, is rate limited #352, suggest maybe for fromMaybe d (f <$> x) #338, warn about things imported hidden but not used #337, add --git flag to additionally check files in git #353, suggest _ <- mapM to mapM_ #357, warn on unnecessary use of MagicHash 2.0.9, released 2017-06-13 #346, don't suggest explicit export lists #344, fix the API so it works with hlint.yaml by default 2.0.8, released 2017-05-21 #342, add back support for - to mean stdin 2.0.7, released 2017-05-16 #340, fix for directory arguments in the .hlint.yaml 2.0.6, released 2017-05-08 Do statements are not redundant if they change an operator parse #333, simplify labels on Parse error, makes it easier to ignore 2.0.5, released 2017-04-19 If the datadir is missing use data/ relative to the executable Fix test mode to obey --datadir 2.0.4, released 2017-04-17 --default adds ignores for any warnings it finds 2.0.3, released 2017-04-12 #312, suggest removing the DeriveAnyClass extension Suggest removing the DeriveLift extension Remove redundant parts from list comprehensions, e.g. [a | True] #326, fix up the bounds on the eta-reduce hint 2.0.2, released 2017-04-10 #323, try and avoid malformatted JSON #324, use `backticks` in notes #324, remove double escaping in note for --json #322, fix the YAML syntax in default.yaml 2.0.1, released 2017-04-07 #320, still read ./HLint.hs if it exists 2.0, released 2017-04-06 #319, add a hint \x -> f <$> g x ==> fmap f . g Don't say how many hints were ignored Add a --default flag #314, allow arguments in YAML configuration files Add maybe False (== x) ==> (== Just x) hint, plus for /= Remove the ability to pass the file on stdin using - as the file Remove encoding from ParseFlags Remove the --encoding/--utf8 options, always use UTF8 #311, suggest writeFile instead of withFile/hPutStr #288, add configurable restrictions Suggest using an export list on modules Look for nearby .hlint.yaml files to supply configuration Support YAML configuration files #308, don't suggest newtype for unboxed types Remove the import "hint" feature for hint inclusion Builtin hints do not need to be imported, can only be ignored Delete HLint2 API #290, add hints suggesting traverse/traverse_ #303, detect unused OverloadedStrings extension #302, detect unused TupleSections extension 1.9.41, released 2017-02-09 #299, warn in some cases when NumDecimals extension is unused #300, warn when LambdaCase extension is unused #301, when suggesting newtype remove strictness annotations #297, better testing that there isn't a performance regression #167, add -j flag for number of threads #292, add fst/snd . unzip ==> map fst/snd Don't suggest module export trick, breaks Haddock 1.9.40, released 2017-01-22 #293, fix the JSON format of the output 1.9.39, released 2016-12-04 #287, don't incorrectly suggest newtype 1.9.38, released 2016-11-24 #279, suggest newtype instead of data #262, add rules to detect redundant castPtr calls Detect unused TypeApplications extension #277, don't enable TypeApplications extension by default Allow haskell-src-exts-1.19 #276, remove multiple redundant parens in one go #160, add a --only CLI option #237, fix incorrect quasi quotes extension warning #257, better bang pattern hints 1.9.37, released 2016-08-08 #255, don't suggest id @Int ==> @Int #252, avoid clashes with GHCJS in the interim 1.9.36, released 2016-07-25 Require haskell-src-exts-1.18 #249, suggest avoiding elem on singletons 1.9.35, released 2016-06-10 #245, fix parse error reports #243, update hlint.ghci to work with modern GHC Require extra-1.4.9 1.9.34, released 2016-06-01 #154, fix some incorrect line numbers in literate Haskell #161, fix literate Haskell and CPP 1.9.33, released 2016-05-30 #240, remove type-incorrect "on" hint #234, warn about join seq #232, suggest <|> instead of mplus in a few cases 1.9.32, released 2016-03-23 #53, require cpphs-1.20.1, has important fixes #224, treat select $ specially, as per esqueleto conventions #231, don't modify qualification on substitutions #229, add void/mapM_/forM_ hints 1.9.31, released 2016-03-01 #222, don't suggest removing ~ if the Strict extension is on 1.9.30, released 2016-02-26 #220, fix incorrect hints of foldr/foldl on a tuple accumulator 1.9.29, released 2016-02-25 #219, add warnings about foldable methods on tuple Put warnings before suggestions in the HTML report 1.9.28, released 2016-02-04 #215, spot newtype deriving inside classes 1.9.27, released 2016-02-01 #203, avoid recompiling everything twice #213, don't suggest removing bang patterns on let Rename HintStructure to HintPattern #208, add an hlint function to the HLint3 API #1, warn about unused DefaultSignatures extension #137, add -XHaskell2010 and fix -XHaskell98 Allow checking even if a function has different arities #193, don't warn on a -> (b -> c), it's sometimes sensible #182, make parse errors severity Error #181, warn on otherwise in a pattern variable #163, eta reduce fun x = f $ x #132, don't ever suggest liftM #99, downgrade built in hints, Error => Warning => Suggestion #99, add a Suggestion level severity #207, make sure you close file handles #205, add hint compare x y == EQ and /= #204, add hint concatMap id ==> concat #202, include refactorings is --json output 1.9.26, released 2016-01-02 #200, fix all lint warnings #143, expose argsSettings 1.9.25, released 2015-11-24 #192, fix stdin output and --refactor 1.9.24, released 2015-11-22 #188, improve spotting redundant brackets around patterns #138, reenable redundant where hint 1.9.23, released 2015-11-19 #184, require haskell-src-exts-1.17 #183, allow test_ as a prefix 1.9.22, released 2015-10-28 Don't suggest redundant lambda on view patterns Add --no-exit-code flag #174, don't suggest string literals #175, disable 'rec' stealing extensions by default #170, add hints for eta-reduced operators #149, integrate a --refactor flag #147, fix the -fglasgow-exts hint #140, better name for moving brackets to eliminate $ Extra hints for <$> Remove a redundant fmap hint #131, add =<< rules in addition to >>= 1.9.21, released 2015-05-26 #130, ignore a BOM if it exists #128, don't find files starting with . when searching directories Suggest concat even if the [] is written "" 1.9.20, released 2015-04-21 #122, fix the zipWith/repeat hint 1.9.19, released 2015-03-26 #119, don't remove RecursiveDo if they use the rec statement Add a suggestion concatMap/map ==> concatMap 1.9.18, released 2015-03-17 More GHC 7.10 warnings and build support 1.9.17, released 2015-02-25 #116, support hscolour-1.21 1.9.16, released 2015-01-09 #108, make "hlint ." work again 1.9.15, released 2015-01-03 #106, avoid warnings with GHC 7.10 #105, build with GHC 7.10 1.9.14, released 2014-12-24 #649, don't suggest const for values using RecordWildCards 1.9.13, released 2014-11-30 #97, remove the encoding bits of the API #98, add an HLint3 prototype API #93, make the --quickcheck tests work on GHC 7.8 Add --tempdir flag to the test mode 1.9.12, released 2014-11-09 #96, fix the --utf8 flag Make Encoding an alias for TextEncoding Default to UTF8 encoding 1.9.11, released 2014-11-07 #95, don't suggest camel case for names containing digits Add a dependency on the extra package #92, use a new way for determining the color default Add a dependency on ansi-terminal 1.9.10, released 2014-10-19 Spot unsafePerformIO without NOINLINE 1.9.9, released 2014-10-13 #89, fix compiling the executable with --flag=-gpl 1.9.8, released 2014-10-08 #82, don't crash on XmlHybrid modules #88, allow avoiding HsColour, as it is GPL licensed #87, don't push if down, since it can be type incorrect 1.9.7, released 2014-10-02 #86, don't use color unless $TERM claims to support it 1.9.6, released 2014-09-30 #85, fix the free variable matching check for lambda #84, suggest fmap for Either Make --json put each hint on a different line Support -X for extensions to the hse mode 1.9.5, released 2014-09-14 Remove support for GHC 7.2 Upgrade to haskell-src-exts-1.16 1.9.4, released 2014-08-27 #81, fixes for GHC 7.9 #78, add hints for list patterns #72, make --color the default on Linux 1.9.3, released 2014-07-28 #73, fix multithreading and exceptions 1.9.2, released 2014-07-23 #68, add --no-summary 1.9.1, released 2014-07-21 #65, add flip (>>=) ==> (=<<) and the reverse #61, add --json flag 1.9, released 2014-06-30 Remove not (isControl x) ==> isPrint (not true for '\173') #57, warn on invalid pragmas Make the API pass and require comments #59, make sure qualified operators match properly Rename notTypeSafe annotation to noTypeCheck Remove an invalid rule suggesting tanh #13, add a --quickcheck flag to test the hints Add --typecheck flag to test mode to type check the hints Remove incorrect for intercalate to unlines #37, remove incorrect hint for isAlphaNum #45, add mapMaybe id ==> catMaybes #42, add some repeat hints 1.8.61, released 2014-04-14 #40, allow haskell-src-exts-1.15 Don't detect redundant Generics extension 1.8.60, released 2014-04-02 #33, add --cpp-file to preinclude a file #34, add back --quiet flag #639, don't suggest evaluate, because not all Monad's are IO #31, delete the elem/notElem hints #30, remove weird "free module" matching #15, add prototype grep mode Change to make test a separate mode #12, more list based suggestions #637, turn off QuasiQuotes by default 1.8.59, released 2014-03-13 #27, fix up directory file searching 1.8.58, released 2014-03-11 Move the API to Language.Haskell.HLint2 #638, ensure $! doesn't break strictness with strict fields #24, don't remove DeriveFunctor even when only on a newtype #22, turn off UnboxedTuples by default #21, strip /* C style */ comments #635 and #18, require cpphs-1.18.1 Switch to CmdArgs for command line parsing Remove -x as a synonym for --cross 1.8.57, released 2014-02-04 #6, add a preview of an API #331, improve parse error locations for literate Haskell 1.8.56, released 2014-01-30 Remove support for GHC 6.12 and below #317, tone down the void hint #16, match not . not (and reverse . reverse etc) Suggest <$> instead of fmap f $ ... Tweak some priorities, make >=> a warn and void an error #3, make top of the file ANN pragmas work #10, add a suggestion to use unlines #11, add a few hints about characters #8, add CHANGES.txt to the Cabal package 1.8.55, released 2013-11-29 #627, fix the UnboxedTuples extension warning 1.8.54, released 2013-11-28 Fix a bug when suggesting const 1.8.53, released 2013-09-24 Fix some corner cases when suggesting foldr etc. #517, don't introduce new free variables in a replacement 1.8.52, released 2013-09-24 #2, Generic is not newtype derivable 1.8.51, released 2013-08-20 Upgrade to haskell-src-exts-1.14 1.8.50, released 2013-08-18 Eliminate upper bounds on all dependencies #617, fix up notIn to take account of Template Haskell variables #573, suggest removing various deriving language extensions 1.8.49, released 2013-07-23 Remove ^^ ==> ** hint Remove a duplicate sqrt hint Ensure that --test failures throws an error Fix up the copyright year in --help 1.8.48, released 2013-07-16 Brackets at the root of annotations are fine Reduce a few more lambda expressions 1.8.47, released 2013-06-28 #613, compatibility with base-4.7 1.8.46, released 2013-06-06 Remove incorrect isPrefixOf hints #586, add span/break/takeWhile/dropWhile hints #588, add sort/reverse hints #601, add replicate/map/repeat hints Add a hint about reverse/reverse Add side as an alias for _ Add hint as an alias for error 1.8.45, released 2013-05-12 #600, hints for unnecessary lazy annotations 1.8.44, released 2013-04-21 #598, warn on unnecessary bang patterns 1.8.43, released 2013-01-27 Change some hint error/warning levels 1.8.42, released 2013-01-23 Allow cpphs-1.16 1.8.41, released 2013-01-19 #586, add a rule for takeWhile/dropWhile ==> span #522, add hints for the state monad #499, fix up the test suite Fix the side conditions for the `isPrefixOf` hint Add hints about take/drop on non positive numbers Add isNat/isPos/isNeg/isNegPos as notes Make the notes a structured type Add --proof feature Retire the Prelude.catch hint Additional boolean equality hints 1.8.40, released 2013-01-06 #585, lots of additional list based hints 1.8.39, released 2012-12-06 #582, don't suggest renaming with trailingHashes# #578, treat _ bindings differently in lambdas 1.8.37, released 2012-12-01 #575, allow cpphs-1.15 1.8.36, released 2012-11-27 Make --with imply no default Hint files 1.8.35, released 2012-11-17 #567, avoid duplicate hints around (.) hints 1.8.34, released 2012-11-06 Switch license from GPL to BSD3 1.8.33, released 2012-10-23 Lots more hints on laziness, foldable and a few others Use mapM_ etc in more situations, when using explicit >>= 1.8.32, released 2012-10-23 Add notes about how to deal with imported fixites Add a --with flag for passing settings on the command line #563, make sure TypeSig hints get the right function name Update the copyright year to 2012 #564, allow brackets and type signatures on annotations Add a note that about using !! if the index is negative 1.8.31, released 2012-08-18 Avoid incomplete patterns when reading ANN pragmas #555, top-level expressions require TemplateHaskell 1.8.30, released 2012-07-11 Add elemIndex/elemIndices hints Allow cpphs-1.14 #551, allow case_ as a name with an underscore 1.8.29, released 2012-06-01 Allow hscolor-1.20.* #574, add a hint to for mapM/zip ==> zipWithM 1.8.28, released 2012-04-01 Fix a bug, >=> hint was missing check about removal of free var 1.8.27, released 2012-03-30 Allow haskell-src-exts-1.13.* 1.8.26, released 2012-03-27 Allow haskell-src-exts-1.12.* Don't suggest redundant brackets when turning ++ into : Add hints suggesting >=> and <=< 1.8.25, released 2012-03-25 Update the copyright year in the Cabal file Allow transformers-0.3.* 1.8.24, released 2012-02-20 #531, Make hlint.ghci well formed again 1.8.23, released 2012-02-05 Add hints for redundant seq/evaluate using isWHNF #526, don't hint for return $! (x :: Int) 1.8.22, released 2012-02-04 Add hint for $! where the RHS is not a variable 1.8.21, released 2012-01-26 #508, add lots of hints from the base library #317, add hints for a >> return () to void Add a fromMaybe/fmap ==> maybe hint #304, don't backet tuple sections Add foldl (++) [] ==> concat #512, detect unnecessary case construct When finding hints, don't abort on a parse error #507, add exitSuccess hint #505, suggest record patterns 1.8.20, released 2011-11-29 #500, make sure eta reduction has position information 1.8.19, released 2011-11-27 #498, eta reduce even if there is a where block #497, don't produce an incorrect lambda when suggesting flip 1.8.18, released 2011-11-05 #438, use Foo.Bar to mean Foo/Bar.hs Add a --path command line option to say where files live #441, avoid bad matches due to automatically eta reducing rules #489, import Foo as Foo is redundant #481, suggest liftM instead of fmap when using the Monad laws 1.8.17, released 2011-10-01 #479, allow - as the file to specify using stdin 1.8.16, released 2011-09-28 #478, allow cpphs-1.13.1 Never suggest view patterns (they aren't sufficiently better) Don't suggest use of Data.Ord.comparing, using `on` is better Only suggest elem/notElem on 3 or more items 1.8.15, released 2011-08-13 Add --cpp-ansi to turn on ANSI compat in cpphs 1.8.14, released 2011-08-12 #455, GHC 7.2 compatibility Add lots of hints from Lennart Augustsson 1.8.13, released 2011-07-05 #302, add a backup fixity analysis, if the HSE one fails Fix x /= y || x /= z ==> x `notElem` [y,z], should be && 1.8.12, released 2011-07-03 Allow cpphs-1.12 1.8.11, released 2011-06-18 #440, suggest removing redundant brackets under do #439, don't add redundant brackets under do 1.8.10, released 2011-06-12 Upgrade to hscolour-1.19 1.8.9, released 2011-05-26 #436, add a hint about mapMaybe/map Upgrade to haskell-src-exts-1.11.1 Add a --cross flag, to detect hints between multiple modules #428, don't suggest using String in an instance head 1.8.8, released 2011-04-03 #384, suggest collapsing multiple imports/exports #374, don't suggest the removal of necessary brackets #337, suggest Control.Exception.catch instead of Prelude.catch #412, add hints based on Control.Exception #378, suggest removing fromInteger/fromIntegral on literals #369, add notes to a few hints about possible pitfalls #409, fix a few cases where definitions suggested themselves #410, Support test* as ignored items in settings files #414, add isLit* pattern, and hint about ^^ ==> ** #420, make the suggestion to use let a warning #408, rework the when/unless hints, don't suggest on itself Add duplicate detector, for copy/pasted code #285, don't show duplicate filepath separators If the user enters directories containing no files then say Make suggesting curry/uncurry a warning instead of an error 1.8.7, released 2011-01-31 Relax the transformers dependency, works with 0.0.* and 0.1.* 1.8.6, released 2011-01-27 Export suggestionSeverity/Severity from the API Allow hint imports with "hlint", as well as the existing "hint" 1.8.5, released 2011-01-23 Update the copyright year to 2011 #400, support more encoding strings, give useful errors #401, rename the report template to report_template.html Replace filter f x /= [] with any f x, and 2 more similar 1.8.4, released 2011-01-12 #308, allow haskell-src-exts-1.10.1, which parses Unicode better import qualified Char ==> import qualified Data.Char as Char #393, fix suggestion for import IO, requires more than System.IO #376, note that RecordWildCards implies DisambiguateRecordFields 1.8.3, released 2010-11-10 Allow uniplate-1.6 Switch from mtl to transformers #373, require haskell-src-exts-1.9.6 Add a type signature for GHC 7 Suggest [x | x <- xs] ==> xs, if x is a variable 1.8.2, released 2010-10-23 #371, foo (\x -> y :: Int -> Int) is not a redundant bracket Add a hint to use just equality rather than isJust/fromJust 1.8.1, released 2010-10-15 Massive speed up for files with many naming hints #361, keep module names when suggesting infix Add support for wildcard matching on module names #357, don't camel case suggest on FOO_A #370, fix building with GHC 6.10.4 #313, upgrade to haskell-src-exts-1.9.4 Workaround for #358, disable empty where hints #355, make "--ignore=Parse error" work Add --cpp-simple to run a simple CPP to strip lines begining # Add bracketing information if the parent is a case Suggest intercalate 1.8, released 2010-09-11 Make --test --hint=file typecheck a file for valid hints #347, Suggest use of otherwise, instead of True, in pattern guards Add hints about redundant where statements Suggest removal of redundant guards Make hints about guards work on patterns/infix matches/case alts Make finding guards look a child functions Correctly collapse functions and lambdas using the same patterns Suggest promoting patterns bound to lambdas to functions Allow collapsing lambdas sharing pattern variables correctly #344, only give one warning for multiple collapsable lambdas #300, substantially improve module name resolution with imports BREAKING: imports in hint files require import "hint" HintFile #335, redundant id should only generate one warning Add a hint for using map (f &&& g) #328, for foo'bar suggest the naming fooBar #323, detect redundant brackets in field declarations #321, force the whole file before displaying a parse error Make --find more robust, fixes a potential parse error 1.7.3, released 2010-07-25 Upgrade to hscolour-1.17 1.7.2, released 2010-06-11 #318, match rules by expanding out (.) #319, don't remove lambdas on the right of infix operators 1.7.1, released 2010-06-07 Add a --quiet flag, to supress stdout (mainly for API users) 1.7, released 2010-06-06 Add support for HLint.Builtin.All Fix crash on (\x -> x) Make the library correctly honour the data directory Improve the manual, mainly language changes and hyperlinking Fix a bug in ListRec, could have _recursive_ in the result #315, spot list rec hints through $ and let Add hints based on (f $) ==> f, and change in ListRec hints Changes to the lambda suggestions, now gives a few more hints Don't suggest importing modules in old-locale/old-time Make the API return the suggestions, rather than just the count #278, add -XNoCpp to disable the C preprocessor #279, add -XExt/-XNoExt to choose extensions Remove some redundant brackets in type replacements #286, remove redundant brackets in match Additional bracket removal, application under sections #299, rework hints to use flip (suggest infix in some cases) Add some fromMaybe hints Fix bug where hints didn't always get names #306, make --find use the hints if there are files specified Upgrade to haskell-src-exts-1.9 #303, allow fixities to be specified in hint files 1.6.21, released 2010-04-07 #287, warn about Haskell 98 imports #297, add a hint to use mplus #288, detect redundant brackets under a lambda #302, remove error about ambiguous fixities #281, enhance the redundant monad return warnings #293, eliminate _noParen_ from the result #284, eliminate ViewPatterns from FindHints, hits compiler bug #283, don't suggest removal of RecordWildCards Add some hints about concat and (++) #273, require haskell-src-exts >= 1.8.2 1.6.20, released 2010-02-10 #275, add more acknowledgements (still very incomplete) #254, remove the foldr1/map hint Compress nested lambdas, \x -> \y -> ... ==> \x y -> ... Fix minor bug on \x -> \x -> foo x x #274, add redundant bracket inside record update/construct #272, don't mess up creating sections from qualified names Add some hints to suggest elem Add Paths_hlint to the .cabal file, or the library doesn't link #271, rewrite the match engine in terms of SYB 1.6.19, released 2010-02-06 #251, add automatic definition hunting with --find #268, rewrite the (.) expansion in hints to fix various bugs #269, replacing a case with an if should generate one hint Document the ANN pragmas Require haskell-src-exts-1.8.1 1.6.18, released 2010-02-02 Remove a hint replacing do x <- foo; bar x with foo >>= bar #263, support CPP files more fully Upgrade to hscolour-1.16 Upgrade to cpphs-1.11 1.6.17, released 2010-02-01 Force cpphs-1.10, since 1.11 breaks the interface More hints from the Data.Maybe module #262, add support for the TupleSections extension #264, upgrade to haskell-src-exts-1.8.*, fixes QuasiQuote pos Upgrade to cpphs 1.10 #266, don't match hints that appear to be the definitions #248, tone down the eta reduction hints Add support for WARNING pragma's to reclassify hints Support ignoring hints on types Give better error messages on incorrect settings files Add temporary haskell-src-exts 1.5/1.6 compatibility #327, add hints to use expressions infix #240, if a then True else False no longer suggests a || False Upgrade to haskell-src-exts-1.7.* #236, support changing the text encoding with --encoding/--utf8 #260, generate nicer lambdas for (($) . f) Add the hint (($) . f) ==> (f $) 1.6.16, released 2010-01-23 Further performance enhancements (for details see my blog) Update to uniplate 1.5.* (fixes performance bug) Improve speed based on profiling (roughly twice as fast) #245, add hints for excess brackets in types and patterns Make 100% redundant brackets an error Fix bug where qualified names did not match Remove dependency on SYB #234, allow TH top-level splices for ignore #110, add tests for ignoring commands 1.6.15, released 2010-01-12 Upgrade to uniplate 1.4.* (fixes performance bug) #192, make HLint into a fairly basic library Add --datadir to allow running with a different data directory #254, eliminate foldl/map fusion rules (which were untrue) Fix a few typos in the hint rules Upgrade to uniplate 1.3.* Upgrade to haskell-src-exts 1.6.* Add a .ghci file snippet #247, Fix bug matching expressions containing position info 1.6.14, released 2010-01-05 Upgrade to haskell-src-exts 1.5.* 1.6.13, released 2010-01-05 #246, redundant brackets in [(...)] Add fold/map fusion hints Don't suggest namings that are already used in the module #239, Add suggestions of and/or on foldl Add --extension flag, to find files not named .hs/.lhs Only activate the builtin hints when they are imported Fix matching bug, said "Use flip" on "\v -> f v . g" Suggest changing some pattern guards to view patterns 1.6.12, released 2009-11-06 Fix a bug with ignored hints being written to reports Upgrade to haskell-src-exts 1.3.* #228, suggest let instead of <- return in do statements #229, suggest comparing Qualify all non-Prelude function suggestions #225, Add redundant flip hint #226, Add ((+) x) ==> (x +) #223, TemplateHaskell may allow other extensions via code Fix incorrect suggestion on do x <- f ; g x x A few small additional hints (use flip, redundant id) 1.6.11, released 2009-09-13 Don't perform type eta reduction 1.6.10, released 2009-09-13 Fix bug, eta reduction on chained infix operators, i.e. x#y#z 1.6.9, released 2009-09-12 #217, don't suggest eta reduction on - or + Fix bug, PatternGuards under case alternatives were ignored 1.6.8, released 2009-09-07 #213, upgrade to cpphs 1.9 Add suggestion to replace lambda with operator sections Fix bug, ''Name decided TemplateHaskell was unnecessary HPC statistics, and increase in test coverage Fix bug, import A as Y; import A gave import A, missing the as Y Fix bug, type Foo a = Bar a a incorrectly suggested eta reduce 1.6.7, released 2009-08-31 NOTE: #213 has not been fixed, cpphs can cause hangs Add threaded flag to Cabal to disable -threaded mode #212, fix crash Fix bug, incorrectly decided TemplateHaskell was unnecessary 1.6.6, released 2009-08-29 Upgrade to hscolour 1.15 Add a hint for using unless #211, add hints for unused extensions #188, add pragma hints Add a few additional hints (Functor laws) #137, add cpphs support #189, give hints for redundant imports Upgrade to haskell-src-exts 1.1.* 1.6.5, released 2009-08-02 #206, better presentation of parse errors #208, give the correct precedence to ==> in source files 1.6.4, released 2009-07-12 Start of changelog hlint-3.5/LICENSE0000644000000000000000000000276407346545000011706 0ustar0000000000000000Copyright Neil Mitchell 2006-2022. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hlint-3.5/README.md0000644000000000000000000010511507346545000012152 0ustar0000000000000000# 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/workflow/status/ndmitchell/hlint/ci/master.svg)](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](./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. 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](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 Installation follows the standard pattern of any Haskell library or program: type `cabal update` to update your local hackage database, then `cabal install hlint` to install HLint. Once HLint is installed, run `hlint source` where `source` is either a Haskell file, or a directory containing Haskell files. A directory will be searched recursively for any files ending with `.hs` or `.lhs`. For example, running HLint over darcs would give: ```console $ hlint darcs-2.1.2 darcs-2.1.2\src\CommandLine.lhs:94:1: Warning: Use concatMap Found: concat $ map escapeC s Perhaps: concatMap escapeC s darcs-2.1.2\src\CommandLine.lhs:103:1: Suggestion: Use fewer brackets Found: ftable ++ (map (\ (c, x) -> (toUpper c, urlEncode x)) ftable) Perhaps: ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Warning: Use a more efficient monadic variant Found: mapM (delete_line (fn2fp f) line) old Perhaps: mapM_ (delete_line (fn2fp f) line) old ... lots more hints ... ``` Each hint says which file/line the hint relates to, how serious an issue it is, a description of the hint, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying `concat` and `map` separately, it would be better to use the combination function `concatMap`. 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. **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations. ### Suggested usage HLint usage tends to proceed in three distinct phases: 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](./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. ### Running with Continuous Integration On CI you might wish to run `hlint .` (or `hlint src` if you only want to check the `src` directory). To avoid the cost of compilation you may wish to fetch the [latest HLint binary release](https://github.com/ndmitchell/hlint/releases/latest). For the CI systems [Travis](https://travis-ci.org/), [Appveyor](https://www.appveyor.com/) and [Azure Pipelines](https://azure.microsoft.com/en-gb/services/devops/pipelines/) add the line: ```sh curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . ``` The arguments after `-s` are passed to `hlint`, so modify the final `.` if you want other arguments. This command works on Windows, Mac and Linux. ### Integrations 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 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. * [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. ### Automatically Applying Hints 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. 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. While the `--refactor` flag is useful, not all hints support refactoring. See [hints.md](hints.md) for which hints don't support refactoring. ### Reports HLint can generate a lot of information, making it difficult to search for particular types of errors. The `--report` flag will cause HLint to generate a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handful of hints. ### Language Extensions 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 Emacs integration has been provided by [Alex Ott](http://xtalk.msk.su/~ott/). The integration is similar to compilation-mode, allowing navigation between errors. The script is at [hs-lint.el](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hs-lint.el), and a copy is installed locally in the data directory. To use, add the following code to the Emacs init file: ```guile (require 'hs-lint) (defun my-haskell-mode-hook () (local-set-key "\C-cl" 'hs-lint)) (add-hook 'haskell-mode-hook 'my-haskell-mode-hook) ``` ### GHCi Integration GHCi integration has been provided by Gwern Branwen. The integration allows running `:hlint` from the GHCi prompt. The script is at [hlint.ghci](https://raw.githubusercontent.com/ndmitchell/hlint/master/data/hlint.ghci), and a copy is installed locally in the data directory. To use, add the contents to your [GHCi startup file](https://www.haskell.org/ghc/docs/latest/html/users_guide/ghci.html#the-ghci-and-haskeline-files). ### Parallel Operation To run HLint on 4 processors append the flags `-j4`. HLint will usually perform fastest if n is equal to the number of physical processors, which can be done with `-j` alone. If your version of GHC does not support the GHC threaded runtime then install with the command: `cabal install --flags="-threaded"` ### C preprocessor support HLint runs the [cpphs C preprocessor](http://hackage.haskell.org/package/cpphs) over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags `--cpp-include` and `--cpp-define`. To disable the C preprocessor use the flag `-XNoCPP`. There are a number of limitations to the C preprocessor support: * HLint will only check one branch of an `#if`, based on which macros have been defined. * Any missing `#include` files will produce a warning on the console, but no information in the reports. ## FAQ ### Usage #### 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 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: * __Increases laziness__ - for example `foldl (&&) True` suggests `and` including this note. The new code will work on infinite lists, while the old code would not. Increasing laziness is usually a good idea. * __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? Every hint has a severity level: * __Error__ - by default only used for parse errors. * __Warning__ - for example `concat (map f x)` suggests `concatMap f x` as a "warning" severity hint. From a style point of view, you should always replace a combination of `concat` and `map` with `concatMap`. * __Suggestion__ - for example `x !! 0` suggests `head x` as a "suggestion" severity hint. Typically `head` is a simpler way of expressing the first element of a list, especially if you are treating the list inductively. However, in the expression `f (x !! 4) (x !! 0) (x !! 7)`, replacing the middle argument with `head` makes it harder to follow the pattern, and is probably a bad idea. Suggestion hints are often worthwhile, but should not be applied blindly. 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. #### 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: ```console Ambiguous type variable ‘t0’ arising from an annotation prevents the constraint ‘(Data.Data.Data t0)’ from being solved. ``` In this case, a solution is to add the `:: String` type annotation. For example: ```haskell {-# ANN someFunc ("HLint: ignore Use fmap" :: String) #-} ``` See discussion in [issue #372](https://github.com/ndmitchell/hlint/issues/372). ## Customizing the hints To customize the hints given by HLint, create a file `.hlint.yaml` in the root of your project. For a suitable default run: ```console hlint --default > .hlint.yaml ``` This default configuration shows lots of examples (as `# comments`) of how to: * 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` 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 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 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`. For `{- HLINT -}` comments they are likely to be treated as comments in syntax highlighting, which can lead to them being overlooked. Ignore directives can also be written in the hint files: * `- 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.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 #ifndef __HLINT__ foo = ( -- HLint would fail to parse this #endif ``` ### Adding hints The hint suggesting `concatMap` can be defined as: ```yaml - warn: {lhs: concat (map f x), rhs: concatMap f x} ``` This line can be read as replace `concat (map f x)` with `concatMap f x`. All single-letter variables are treated as substitution parameters. For examples of more complex hints see the supplied `hlint.yaml` file in the data directory. This hint will automatically match `concat . map f` and `concat $ map f x`, so there is no need to give eta-reduced variants of the hints. Hints may tagged with `error`, `warn` or `suggest` to denote how severe they are by default. In addition, `hint` is a synonym for `suggest`. If you come up with interesting hints, please submit them for inclusion. You can search for possible hints to add from a source file with the `--find` flag, for example: ```console $ hlint --find=src/Utils.hs -- hints found in src/Util.hs - warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"} - warn: {lhs: "dropWhile isSpace", rhs: "trimStart"} - fixity: "infixr 5 !:" ``` These hints are suitable for inclusion in a custom hint file. You can also include Haskell fixity declarations in a hint file, and these will also be extracted. If you pass only `--find` flags then the hints will be written out, if you also pass files/folders to check, then the found hints will be automatically used when checking. Hints can specify more advanced aspects, with names and side conditions. To see examples and descriptions of these features look at [the default hint file](https://github.com/ndmitchell/hlint/blob/master/data/hlint.yaml) and [the hint interpretation module comments](https://github.com/ndmitchell/hlint/blob/master/src/Hint/Match.hs). ### Restricting items HLint can restrict what Haskell code is allowed, which is particularly useful for larger projects which wish to enforce coding standards - there is a short example in the [HLint repo itself](https://github.com/ndmitchell/hlint/blob/master/.hlint.yaml#L10-L32). As an example of restricting extensions: ```yaml - extensions: - default: false - name: [DeriveDataTypeable, GeneralizedNewtypeDeriving] - {name: CPP, within: CompatLayer} ``` The above block declares that GHC extensions are not allowed by default, apart from `DeriveDataTypeable` and `GeneralizedNewtypeDeriving` which are available everywhere. The `CPP` extension is only allowed in the module `CompatLayer`. Much like `extensions`, you can use `flags` to limit the `GHC_OPTIONS` flags that are allowed to occur. You can also ban certain functions: ```yaml - functions: - {name: nub, within: []} - {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. 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 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: '**', importStyle: post} ``` ## Hacking HLint Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). ### 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 `` code comment blocks. Here are some examples: ```haskell {- Tests to check the zipFrom hint works zip [1..length x] x -- zipFrom 1 x zip [1..length y] x zip [1..length x] x -- ??? @Warning -} ``` 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 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. hlint-3.5/Setup.hs0000644000000000000000000000005607346545000012325 0ustar0000000000000000import Distribution.Simple main = defaultMain hlint-3.5/data/0000755000000000000000000000000007346545000011601 5ustar0000000000000000hlint-3.5/data/HLint_QuickCheck.hs0000644000000000000000000001123407346545000015246 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} -- | Used with --quickcheck module HLint_QuickCheck(module HLint_QuickCheck, module X) where import System.IO.Unsafe import Data.Typeable import Data.List import Data.Maybe import Data.IORef import Control.Exception import Control.Monad import System.IO import Control.Concurrent.Chan import System.Mem.Weak(Weak) import Test.QuickCheck hiding ((==>)) import Test.QuickCheck.Test hiding (test) import Test.QuickCheck.Modifiers as X default(Maybe Bool,[Bool],Int,Dbl) -- We need a Show instance that nails down the sides, so defaulting works. -- The one from Text.Show.Functions is insufficient. instance (Show a, Show b) => Show (a -> b) where show _ = "" newtype Dbl = Dbl Double deriving (Enum,Floating,Fractional,Num,Read,Real,RealFloat,RealFrac,Show,Typeable,Arbitrary,CoArbitrary) instance Eq Dbl where Dbl a == Dbl b | isNaN a && isNaN b = True | otherwise = abs (a - b) < 1e-4 || let s = a+b in s /= 0 && abs ((a-b)/s) < 1e-8 instance Ord Dbl where compare a b | a == b = EQ compare (Dbl a) (Dbl b) = compare a b newtype NegZero a = NegZero a deriving (Typeable, Show) instance (Num a, Arbitrary a) => Arbitrary (NegZero a) where arbitrary = fmap (NegZero . negate . abs) arbitrary newtype Nat a = Nat a deriving (Typeable, Show) instance (Num a, Arbitrary a) => Arbitrary (Nat a) where arbitrary = fmap (Nat . abs) arbitrary newtype Compare a = Compare (a -> a -> Ordering) deriving (Typeable, Show) instance (Ord a, Arbitrary a) => Arbitrary (Compare a) where arbitrary = fmap (\b -> Compare $ (if b then flip else id) compare) arbitrary instance Show a => Show (IO a) where show _ = "" instance Show a => Show (Weak a) where show _ = "" instance Show a => Show (Chan a) where show _ = "" instance Eq (IO a) where _ == _ = True instance Eq SomeException where a == b = show a == show b deriving instance Typeable IOMode instance Arbitrary Handle where arbitrary = elements [stdin, stdout, stderr] instance CoArbitrary Handle where coarbitrary _ = variant 0 instance Arbitrary IOMode where arbitrary = elements [ReadMode,WriteMode,AppendMode,ReadWriteMode] instance Arbitrary a => Arbitrary (IO a) where arbitrary = fmap return arbitrary instance Arbitrary (Chan a) where arbitrary = return $ unsafePerformIO newChan instance Exception (Maybe Bool) data Test a = Test Bool a a deriving (Show, Typeable) instance Functor Test where fmap f (Test a b c) = Test a (f b) (f c) a ==> b = Test False a b a ?==> b = Test True a b class Testable2 a where property2 :: Test a -> Property instance Testable2 a => Testable (Test a) where property = property2 instance Eq a => Testable2 a where property2 (Test bx (catcher -> x) (catcher -> y)) = property $ (bx && isNothing x) || x == y instance (Arbitrary a, Show a, Testable2 b) => Testable2 (a -> b) where property2 x = property $ \a -> fmap ($ a) x {-# NOINLINE bad #-} bad :: IORef Int bad = unsafePerformIO $ newIORef 0 test :: (Show p, Testable p, Typeable p) => FilePath -> Int -> String -> p -> IO () test file line hint p = do res <- quickCheckWithResult stdArgs{chatty=False} p unless (isSuccess res) $ do putStrLn $ "\n" ++ file ++ ":" ++ show line ++ ": " ++ hint print $ typeOf p putStr $ output res modifyIORef bad (+1) catcher :: a -> Maybe a catcher x = unsafePerformIO $ do res <- try $ evaluate x return $ case res of Left (_ :: SomeException) -> Nothing Right v -> Just v _noParen_ = id withMain :: IO () -> IO () withMain act = do act bad <- readIORef bad when (bad > 0) $ error $ "Failed " ++ show bad ++ " tests" --------------------------------------------------------------------- -- EXAMPLES main :: IO () main = withMain $ do let t = \ a -> (findIndex ((==) a)) ==> (elemIndex a) in test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" t let t = ((foldr1 (&&)) ?==> (and)) in test "data\\Default.hs" 179 "foldr1 (&&) ==> and" t let t = \ x -> (sqrt x) ==> (x ** 0.5) in test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" t let t = \ (NegZero i) x -> (take i x) ==> ([]) in test "data\\Default.hs" 154 "take i x ==> []" t let t = \ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x) in test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" t let t = \ f -> ((f $)) ==> (f) in test "data\\Default.hs" 218 "(f $) ==> f" t hlint-3.5/data/HLint_TypeCheck.hs0000644000000000000000000000047107346545000015114 0ustar0000000000000000 -- Used with --typecheck module HLint_TypeCheck where (==>) :: a -> a -> a (==>) = undefined _noParen_ = id --------------------------------------------------------------------- -- EXAMPLES main :: IO () main = return () {-# LINE 116 "data\\Default.hs" #-} _test64 = \ p x -> (and (map p x)) ==> (all p x) hlint-3.5/data/Test.hs0000644000000000000000000000575007346545000013063 0ustar0000000000000000-- These hints are for test purposes, and are not intended to -- be used for real. -- FIXME: Should make this module modules in one file, so can easily test lots of -- things without them overlapping module HLint.Test where error = Prelude.readFile ==> bad error = (x :: Int) ==> (x :: Int32) where _ = noTypeCheck error "Test1" = scanr ==> scanr error "Test2" = filter ==> filter error "Test3" = foldr ==> foldr error "Test4" = foldl ==> foldl ignore "Test1" = "" ignore "Test3" ignore "Test2" = ignoreTest warn = ignoreTest3 suggest = ignoreTest4 ignore = Ignore_Test {-# ANN module "HLint: ignore Test4" #-} {-# ANN annTest2 "HLint: error" #-} {-# ANN annTest3 ("HLint: warn" :: String) #-} {-# ANN annTest4 ("HLint: suggest" :: String) #-} {-# ANN type Ann_Test ("HLint: ignore") #-} error = concat (map f x) ==> Data.List.concatMap f x infix 9 + error = a * (b+c) ==> undefined error = Array.head ==> head error = tail ==> Array.tail warn = id Control.Arrow.*** id ==> id error = zip [1..length x] x ==> zipFrom 1 x error = before a ==> after a warn "noop" = a ? 0 ==> a {- <--! TEST (temporarily disabled see issue https://github.com/ndmitchell/hlint/issues/809) !--> main = readFile "foo" >>= putStr \ -- bad import Prelude hiding(readFile) \ import Data.ByteString.Char8(readFile) \ test = readFile "foo" >>= putStr import Prelude as Prelude2 \ yes = Prelude2.readFile "foo" >>= putStr \ -- bad yes = 32 :: Int -- 32 :: Int32 yes = before 12 -- after 12 ignoreTest = filter -- @Ignore ??? ignoreTest2 = filter -- @Error ??? ignoreTest3 = filter -- @Warning ??? ignoreTest4 = filter -- @Suggestion ??? ignoreAny = scanr -- @Ignore ??? ignoreNew = foldr -- @Ignore ??? type Ignore_Test = Int -- @Ignore ??? annTest = foldl -- @Ignore ??? annTest2 = foldl -- @Error ??? annTest3 = scanr -- @Warning ??? annTest4 = scanr -- @Suggestion ??? type Ann_Test = Int -- @Ignore ??? concatMap f x = concat (map f x) concatMop f x = concat (map f x) -- Data.List.concatMap f x yes = 1 * 2+3 -- undefined import Foo; test = Foo.id 1 test = head import Array; test = Array.head -- head test = Array.head -- head test = head import qualified Array; test = head import Array(tail); test = head import Array(head); test = head -- head import Array as A; test = A.head -- head test = tail -- Array.tail import qualified Array as B; test = tail -- B.tail import Control.Arrow; test = id *** id -- id test = id Control.Arrow.*** id -- id import Control.Arrow as Q; test = id Q.*** id -- id zip [1..length x] zip [1..length x] x -- zipFrom 1 x test = 5 + 0 -- 5 {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \ {-# LANGUAGE RecordWildCards #-} -- @Ignore ??? {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \ {-# LANGUAGE RecordWildCards #-} -- @Ignore ??? {-# ANN lam "HLint: ignore Redundant lambda" #-} \ lam = \x -> x x x -- @Ignore ??? {-# ANN module "HLint: ignore Reduce duplication" #-} \ dup = do a; a; a; a; a; a -- @Ignore ??? -} hlint-3.5/data/default.yaml0000644000000000000000000000371607346545000014120 0ustar0000000000000000# 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 # Specify additional command line arguments # # - arguments: [--color, --cpp-simple, -XQuasiQuotes] # Control which extensions/flags/modules/functions can be used # # - extensions: # - default: false # all extension are banned by default # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module # # - flags: # - {name: -w, within: []} # -w is allowed nowhere # # - modules: # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' # - {name: Control.Arrow, within: []} # Certain modules are banned entirely # # - functions: # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules # Add custom hints for this project # # 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 # # Ban "module X(module X) where", to require a real export list # - warn: {name: Use explicit module export list} # # Replace a $ b $ c with a . b $ c # - group: {name: dollar, enabled: true} # # Generalise map to fmap, ++ to <> # - group: {name: generalise, enabled: true} # Ignore some builtin hints # - ignore: {name: Use let} # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules # Define some custom infix operators # - fixity: infixr 3 ~^#^~ # To generate a suitable file for HLint do: # $ hlint --default > .hlint.yaml hlint-3.5/data/hintrule-implies-classify.yaml0000644000000000000000000000006107346545000017567 0ustar0000000000000000- ignore: { } - warn: {lhs: mapM, rhs: traverse} hlint-3.5/data/hlint-restrict-extensions.yaml0000644000000000000000000000017107346545000017634 0ustar0000000000000000- extensions: - {name: DeriveFunctor, within: []} - {name: DeriveTraversable, within: [], message: "Custom message"} hlint-3.5/data/hlint.10000644000000000000000000000242407346545000013003 0ustar0000000000000000.TH HLINT "1" "July 2009" "HLint (C) Neil Mitchell 2006-2009" "User Commands" .SH NAME HLint \- haskell source code suggestions .SH SYNOPSIS .B hlint [\fIfiles/directories\fR] [\fIoptions\fR] .SH DESCRIPTION \fIHLint\fR is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. .SH OPTIONS .TP \fB\-?\fR \fB\-\-help\fR Display help message .TP \fB\-v\fR \fB\-\-version\fR Display version information .TP \fB\-r[file]\fR \fB\-\-report\fR[=\fIfile\fR] Generate a report in HTML .TP \fB\-h\fR \fIfile\fR \fB\-\-hint\fR=\fIfile\fR Hint/ignore file to use .TP \fB\-c\fR \fB\-\-color\fR, \fB\-\-colour\fR Color the output (requires ANSI terminal) .TP \fB\-i\fR \fImessage\fR \fB\-\-ignore\fR=\fImessage\fR Ignore a particular hint .TP \fB\-s\fR \fB\-\-show\fR Show all ignored ideas .TP \fB\-t\fR \fB\-\-test\fR Run in test mode .SH EXAMPLE "To check all Haskell files in 'src' and generate a report type:" .IP hlint src \fB\-\-report\fR .SH "SEE ALSO" The full documentation for .B HLint is available in \fI/usr/share/doc/hlint/hlint.html\fI. .SH AUTHOR This manual page was written by Joachim Breitner for the Debian system (but may be used by others). hlint-3.5/data/hlint.ghci0000644000000000000000000000244407346545000013557 0ustar0000000000000000-- -*- mode: haskell; -*- -- Begin copied material. -- :{ :def redir \varcmd -> return $ case break Data.Char.isSpace varcmd of (var,_:cmd) -> unlines [":set -fno-print-bind-result" ,"tmp <- System.Directory.getTemporaryDirectory" ,"(f,h) <- System.IO.openTempFile tmp \"ghci\"" ,"sto <- GHC.IO.Handle.hDuplicate System.IO.stdout" ,"GHC.IO.Handle.hDuplicateTo h System.IO.stdout" ,"System.IO.hClose h" ,cmd ,"GHC.IO.Handle.hDuplicateTo sto System.IO.stdout" ,"let readFileNow f = readFile f >>= \\t->Data.List.length t `seq` return t" ,var++" <- readFileNow f" ,"System.Directory.removeFile f" ] _ -> "putStrLn \"usage: :redir \"" :} --- Integration with the hlint code style tool :{ :def hlint \extra -> return $ unlines [":unset +t +s" ,":set -w" ,":redir hlintvar1 :show modules" ,":cmd return $ \":! hlint \" ++ unwords (map (takeWhile (/=',') . drop 2 . dropWhile (/= '(')) $ lines hlintvar1) ++ \" \" ++ " ++ show extra ,":set +t +s -Wall" ] :} hlint-3.5/data/hlint.yaml0000644000000000000000000022244707346545000013616 0ustar0000000000000000# hlint configuration file # ================================== # The hlint tool is mainly automatic, but some hints/restrictions can be specified here. - package: name: base modules: - import Prelude - import Control.Arrow - import Control.Exception - import Control.Monad - import Control.Monad.Trans.State - import qualified Data.Foldable - import Data.Foldable(asum, sequenceA_, traverse_, for_) - import Data.Traversable(traverse, for) - import Control.Applicative - import Data.Bifunctor - import Data.Function - import Data.Int - import Data.Char - import Data.List as Data.List - import Data.List as X - import Data.Maybe - import Data.Monoid - import System.IO - import Control.Concurrent.Chan - import System.Mem.Weak - import Control.Exception.Base - import System.Exit - import Data.Either - import Numeric - 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 modules: - import Control.Lens - import Control.Lens.Operators - import Control.Monad.Reader - package: name: attoparsec modules: - 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 imports: - package base rules: # 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} - warn: {lhs: hGetContents stdin, rhs: getContents} - warn: {lhs: hPutChar stdout, rhs: putChar} - warn: {lhs: hPutStr stdout, rhs: putStr} - warn: {lhs: hPutStrLn stdout, rhs: putStrLn} - warn: {lhs: hPrint stdout, rhs: print} - warn: {lhs: hWaitForInput a 0, rhs: hReady a} - warn: {lhs: hPutStrLn a (show b), rhs: hPrint a b} - warn: {lhs: hIsEOF stdin, rhs: isEOF} - warn: {lhs: withFile f WriteMode (\h -> hPutStr h x), rhs: writeFile f x} - warn: {lhs: withFile f WriteMode (\h -> hPutStrLn h x), rhs: writeFile f (x ++ "\n")} - warn: {lhs: withFile f AppendMode (\h -> hPutStr h x), rhs: appendFile f x} - warn: {lhs: withFile f AppendMode (\h -> hPutStrLn h x), rhs: appendFile f (x ++ "\n")} # EXIT - warn: {lhs: exitWith ExitSuccess, rhs: exitSuccess} # ORD - warn: {lhs: not (a == b), rhs: a /= b, note: incorrect if either value is NaN} - warn: {lhs: not (a /= b), rhs: a == b, note: incorrect if either value is NaN} - warn: {lhs: not (a > b), rhs: a <= b, note: incorrect if either value is NaN} - warn: {lhs: not (a >= b), rhs: a < b, note: incorrect if either value is NaN} - warn: {lhs: not (a < b), rhs: a >= b, note: incorrect if either value is NaN} - warn: {lhs: not (a <= b), rhs: a > b, note: incorrect if either value is NaN} - warn: {lhs: compare x y /= GT, rhs: x <= y} - warn: {lhs: compare x y == LT, rhs: x < y} - warn: {lhs: compare x y /= LT, rhs: x >= y} - warn: {lhs: compare x y == GT, rhs: x > y} - warn: {lhs: compare x y == EQ, rhs: x == y} - warn: {lhs: compare x y /= EQ, rhs: x /= y} - warn: {lhs: head (sort x), rhs: minimum x} - 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, note: Stabilizes sort order} - warn: {lhs: sortBy (flip (comparing f)), rhs: sortOn (Down . f)} - warn: {lhs: sortBy (comparing f), rhs: sortOn f, side: notEq f fst && notEq f snd} - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order} # This suggestion likely costs performance, see https://github.com/ndmitchell/hlint/issues/669#issuecomment-607154496 # - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order} - hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip} - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on} - 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} - hint: {lhs: showIntAtBase 8 intToDigit, rhs: showOct} # LIST - warn: {lhs: concat (map f x), rhs: concatMap f x} - warn: {lhs: concat (f <$> x), rhs: concatMap f x} - warn: {lhs: concat (fmap f x), rhs: concatMap f x} - hint: {lhs: "concat [a, b]", rhs: a ++ b} - 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: "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: isPrefixOf (reverse x) (reverse y), rhs: isSuffixOf x y} - warn: {lhs: "foldr (++) []", rhs: concat} - warn: {lhs: foldr (++) "", rhs: concat} - warn: {lhs: "foldr ((++) . f) []", rhs: concatMap f} - warn: {lhs: foldr ((++) . f) "", rhs: concatMap f} - warn: {lhs: "foldl (++) []", rhs: concat, note: IncreasesLaziness} - warn: {lhs: foldl (++) "", rhs: concat, note: IncreasesLaziness} - warn: {lhs: foldl f (head x) (tail x), rhs: foldl1 f x} - warn: {lhs: foldr f (last x) (init x), rhs: foldr1 f x} - warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"} - warn: {lhs: foldr (.) id l z, rhs: foldr ($) z l} - warn: {lhs: span (not . p), rhs: break p} - warn: {lhs: break (not . p), rhs: span p} - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness} - 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} - hint: {lhs: 1 > length x, rhs: null x, note: IncreasesLaziness} - hint: {lhs: length x <= 0, rhs: null x, note: IncreasesLaziness} - 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 :"} - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)} - hint: {lhs: "map f (fromMaybe [] x)", rhs: "maybe [] (map f) x"} - warn: {lhs: not (elem x y), rhs: notElem x y} - hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map} - warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"} - 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} - warn: {lhs: all ((/=) a), rhs: notElem a, note: ValidInstance Eq a} - warn: {lhs: all (/= a), rhs: notElem a, note: ValidInstance Eq a} - 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: findIndex ((==) a), rhs: elemIndex a} - warn: {lhs: findIndex (a ==), rhs: elemIndex a} - warn: {lhs: findIndex (== a), rhs: elemIndex a} - warn: {lhs: findIndices ((==) a), rhs: elemIndices a} - warn: {lhs: findIndices (a ==), rhs: elemIndices a} - warn: {lhs: findIndices (== a), rhs: elemIndices a} - 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} - hint: {lhs: 0 < length x, rhs: not (null x), note: IncreasesLaziness, name: Use null} - hint: {lhs: length x >= 1, rhs: not (null x), note: IncreasesLaziness, name: Use null} - hint: {lhs: 1 <= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null} - warn: {lhs: take i x, rhs: "[]", side: isNegZero i, name: Take on a non-positive} - 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: zip (repeat x), rhs: "map (_noParen_ x,)", note: RequiresExtension TupleSections} - 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} - 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 (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_ (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 (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/fmap} - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x, name: Fuse foldMap/fmap} - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x, name: Fuse foldMap/map} # BY - warn: {lhs: deleteBy (==), rhs: delete} - warn: {lhs: groupBy (==), rhs: group} - warn: {lhs: insertBy compare, rhs: insert} - warn: {lhs: intersectBy (==), rhs: intersect} - warn: {lhs: maximumBy compare, rhs: maximum} - warn: {lhs: minimumBy compare, rhs: minimum} - warn: {lhs: nubBy (==), rhs: nub} - warn: {lhs: sortBy compare, rhs: sort} - warn: {lhs: unionBy (==), rhs: union} # 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} - warn: {lhs: foldr1 (&&) , rhs: and, note: "RemovesError on `[]`"} - warn: {lhs: foldl1 (&&) , rhs: and, note: "RemovesError on `[]`"} - warn: {lhs: foldr (||) False, rhs: or} - warn: {lhs: foldl (||) False, rhs: or, note: IncreasesLaziness} - warn: {lhs: foldr1 (||) , rhs: or, note: "RemovesError on `[]`"} - warn: {lhs: foldl1 (||) , rhs: or, note: "RemovesError on `[]`"} - warn: {lhs: foldl (+) 0, rhs: sum} - warn: {lhs: foldr (+) 0, rhs: sum} - warn: {lhs: foldl1 (+) , rhs: sum, note: "RemovesError on `[]`"} - warn: {lhs: foldr1 (+) , rhs: sum, note: "RemovesError on `[]`"} - warn: {lhs: foldl (*) 1, rhs: product} - warn: {lhs: foldr (*) 1, rhs: product} - warn: {lhs: foldl1 (*) , rhs: product, note: "RemovesError on `[]`"} - warn: {lhs: foldr1 (*) , rhs: product, note: "RemovesError on `[]`"} - warn: {lhs: foldl1 max , rhs: maximum} - warn: {lhs: foldr1 max , rhs: maximum} - warn: {lhs: foldl1 min , rhs: minimum} - warn: {lhs: foldr1 min , rhs: minimum} - warn: {lhs: foldr mplus mzero, rhs: msum} # FUNCTION - 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: "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} - warn: {lhs: curry (uncurry f), rhs: f} - 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: (& 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 && 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: 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} # CHAR - 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} # BOOL - warn: {lhs: x == True, rhs: x, name: Redundant ==} - 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} - warn: {lhs: if a then t else (if b then t else f), rhs: if a || b then t else f, name: Redundant if} - 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} - hint: {lhs: "case a of {False -> f; _ -> t}", rhs: if a then t else f, name: Use if} - hint: {lhs: "if c then (True, x) else (False, x)", rhs: "(c, x)", note: IncreasesLaziness, name: Redundant if} - hint: {lhs: "if c then (False, x) else (True, x)", rhs: "(not c, x)", note: IncreasesLaziness, name: Redundant if} - hint: {lhs: "or [x, y]", rhs: x || y} - hint: {lhs: "or [x, y, z]", rhs: x || y || z} - hint: {lhs: "and [x, y]", rhs: x && y} - hint: {lhs: "and [x, y, z]", rhs: x && y && z} - 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} # 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 -> (f x, g x)", rhs: f Control.Arrow.&&& g} - 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: fmap id, rhs: id, name: Functor law} - warn: {lhs: id <$> x, rhs: x, name: Functor law} - 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 *> 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} - hint: {lhs: return x <* y, rhs: x Data.Functor.<$ y} - hint: {lhs: const x <$> y, rhs: x <$ y} - hint: {lhs: pure x <$> y, rhs: x <$ y} - hint: {lhs: return x <$> y, rhs: x <$ y} - 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} # APPLICATIVE - 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: x <* return y, rhs: x} - warn: {lhs: pure x *> y, rhs: "y"} - warn: {lhs: return x *> y, rhs: "y"} # 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 >>= 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 (fmap f x), rhs: mapM f x} - warn: {lhs: sequence_ (f <$> x), 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: unless (not x), rhs: when x} - warn: {lhs: x >>= id, 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 (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, 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: f <$> return x, rhs: return (f x)} - warn: {lhs: mapM (uncurry f) (zip l m), rhs: zipWithM f l m} - warn: {lhs: mapM_ (void . f), rhs: mapM_ f} - warn: {lhs: forM_ x (void . f), rhs: forM_ x f} - warn: {lhs: a >>= \_ -> b, rhs: a >> b} - warn: {lhs: m <* pure x, rhs: m} - warn: {lhs: m <* return x, rhs: m} - warn: {lhs: pure x *> m, rhs: m} - warn: {lhs: return x *> m, rhs: m} - warn: {lhs: pure x >> m, rhs: m} - warn: {lhs: return x >> m, rhs: m} # STATE MONAD - warn: {lhs: fst (runState x y), rhs: evalState x y} - warn: {lhs: snd (runState x y), rhs: execState x y} # MONAD LIST - warn: {lhs: unzip <$> mapM f x, 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} - warn: {lhs: mapM_ f (map g x), rhs: mapM_ (f . g) x, name: Fuse mapM_/map} - warn: {lhs: traverse f (map g x), rhs: traverse (f . g) x, name: Fuse traverse/map} - warn: {lhs: traverse_ f (map g x), rhs: traverse_ (f . g) x, name: Fuse traverse_/map} - warn: {lhs: mapM id, rhs: sequence} - warn: {lhs: mapM_ id, rhs: sequence_} # APPLICATIVE / TRAVERSABLE - warn: {lhs: flip traverse, rhs: for} - warn: {lhs: flip for, rhs: traverse} - warn: {lhs: flip traverse_, rhs: for_} - warn: {lhs: flip for_, rhs: traverse_} - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_} - warn: {lhs: foldr (*>) (return ()), rhs: sequenceA_} - warn: {lhs: foldr (<|>) empty, rhs: asum} - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)} - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)} - warn: {lhs: liftA2 f (return x), rhs: fmap (f x)} - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a} - 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 - 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 - warn: {lhs: seq x x, rhs: x, name: Redundant seq} - warn: {lhs: join seq, rhs: id, name: Redundant seq} - warn: {lhs: id $! x, rhs: x, name: Redundant $!} - warn: {lhs: seq x y, rhs: "y", side: isWHNF x, name: Redundant seq} - warn: {lhs: f $! x, rhs: f x, side: isWHNF x, name: Redundant $!} - warn: {lhs: evaluate x, rhs: return x, side: isWHNF x, name: Redundant evaluate} - warn: {lhs: seq (rnf x) (), rhs: rnf x, name: Redundant seq} # TUPLE - 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} # 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 ==), note: ValidInstance Eq x} - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x} # 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} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053 - ignore: {lhs: fromMaybe True x, rhs: Just False /= x} - 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 (fmap f x), rhs: mapMaybe f x} - 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 x), rhs: Data.Maybe.catMaybes x} - warn: {lhs: x == Nothing , rhs: isNothing x} - warn: {lhs: Nothing == x , rhs: isNothing x} - warn: {lhs: x /= Nothing , rhs: Data.Maybe.isJust x} - warn: {lhs: Nothing /= x , rhs: Data.Maybe.isJust x} - warn: {lhs: concatMap (maybeToList . f), rhs: Data.Maybe.mapMaybe f} - warn: {lhs: concatMap maybeToList, rhs: catMaybes} - warn: {lhs: maybe n Just x, rhs: x Control.Applicative.<|> n} - 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: 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: mapMaybe id, rhs: catMaybes} - 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} - warn: {lhs: maybe x f (g <$> y), rhs: maybe x (f . g) y, name: Redundant fmap} - 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 (fmap f x), rhs: isJust x} - warn: {lhs: isNothing (f <$> x), rhs: isNothing x} - warn: {lhs: isNothing (fmap f x), rhs: isNothing x} - warn: {lhs: fromJust (f <$> x), 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 fmap} - 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} # EITHER - 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: isLeft (fmap f x), rhs: isLeft x} - warn: {lhs: isRight (fmap f x), rhs: isRight x} - warn: {lhs: fromLeft x (fmap f y), rhs: fromLeft x y} - warn: {lhs: fromRight x (fmap f y), 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 - hint: {lhs: elem x y, rhs: x `elem` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: notElem x y, rhs: x `notElem` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: isInfixOf x y, rhs: x `isInfixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: isSuffixOf x y, rhs: x `isSuffixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: isPrefixOf x y, rhs: x `isPrefixOf` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: union x y, rhs: x `union` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} - hint: {lhs: intersect x y, rhs: x `intersect` y, side: not (isInfixApp original) && not (isParen result), name: Use infix} # MATHS - warn: {lhs: fromIntegral x, rhs: x, side: isLitInt x, name: Redundant fromIntegral} - warn: {lhs: fromInteger x, rhs: x, side: isLitInt x, name: Redundant fromInteger} - hint: {lhs: x + negate y, rhs: x - y} - hint: {lhs: 0 - x, rhs: negate x} - warn: {lhs: negate (negate x), rhs: x, name: Redundant negate} - hint: {lhs: log y / log x, rhs: logBase x y} - hint: {lhs: sin x / cos x, rhs: tan x} - hint: {lhs: rem n 2 == 0, rhs: even n} - 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} - hint: {lhs: x ^ 0, rhs: "1", name: Use 1} - hint: {lhs: round (x - 0.5), rhs: floor x} # CONCURRENT - hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a} - error: {lhs: atomically (readTVar x), rhs: readTVarIO x} - error: {lhs: atomically (newTVar x), rhs: newTVarIO x} - error: {lhs: atomically (newTMVar x), rhs: newTMVarIO x} - error: {lhs: atomically newEmptyTMVar, rhs: newEmptyTMVarIO} # TYPEABLE - hint: {lhs: "typeOf (a :: b)", rhs: "typeRep (Proxy :: Proxy b)"} # EXCEPTION - hint: {lhs: flip Control.Exception.catch, rhs: handle} - hint: {lhs: flip handle, rhs: Control.Exception.catch} - hint: {lhs: flip (catchJust p), rhs: handleJust p} - hint: {lhs: flip (handleJust p), rhs: catchJust p} - hint: {lhs: Control.Exception.bracket b (const a) (const t), rhs: Control.Exception.bracket_ b a t} - hint: {lhs: Control.Exception.bracket (openFile x y) hClose, rhs: withFile x y} - hint: {lhs: Control.Exception.bracket (openBinaryFile x y) hClose, rhs: withBinaryFile x y} - hint: {lhs: throw (ErrorCall a), rhs: error a} - warn: {lhs: toException NonTermination, rhs: nonTermination} - warn: {lhs: toException NestedAtomically, rhs: nestedAtomically} # IOREF - hint: {lhs: modifyIORef r (const x), rhs: writeIORef r x} - hint: {lhs: modifyIORef r (\v -> x), rhs: writeIORef r x} # STOREABLE/PTR - hint: {lhs: castPtr nullPtr, rhs: nullPtr} - hint: {lhs: castPtr (castPtr x), rhs: castPtr x} - hint: {lhs: plusPtr (castPtr x), rhs: plusPtr x} - hint: {lhs: minusPtr (castPtr x), rhs: minusPtr x} - hint: {lhs: minusPtr x (castPtr y), rhs: minusPtr x y} - hint: {lhs: peekByteOff (castPtr x), rhs: peekByteOff x} - hint: {lhs: pokeByteOff (castPtr x), rhs: pokeByteOff x} # WEAK POINTERS - warn: {lhs: mkWeak a a b, rhs: mkWeakPtr a b} - warn: {lhs: "mkWeak a (a, b) c", rhs: mkWeakPair a b c} # FOLDABLE - warn: {lhs: case m of Nothing -> pure (); Just x -> f x, rhs: Data.Foldable.forM_ 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.forM_ 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.forM_ 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} # STATE MONAD - warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f} - warn: {lhs: fmap f Control.Monad.State.get, rhs: gets f} - warn: {lhs: f <$> Control.Monad.State.gets g, rhs: gets (f . g)} - warn: {lhs: fmap f (Control.Monad.State.gets g), rhs: gets (f . g)} - warn: {lhs: f <$> Control.Monad.Reader.ask, rhs: asks f} - warn: {lhs: fmap f Control.Monad.Reader.ask, rhs: asks f} - warn: {lhs: f <$> Control.Monad.Reader.asks g, rhs: asks (f . g)} - warn: {lhs: fmap f (Control.Monad.Reader.asks g), rhs: asks (f . g)} - warn: {lhs: fst (runState m s), rhs: evalState m s} - warn: {lhs: snd (runState m s), rhs: execState m s} # EVALUATE - warn: {lhs: True && x, rhs: x, name: Evaluate} - warn: {lhs: False && x, rhs: "False", name: Evaluate} - warn: {lhs: True || x, rhs: "True", name: Evaluate} - warn: {lhs: False || x, rhs: x, name: Evaluate} - warn: {lhs: not True, rhs: "False", name: Evaluate} - warn: {lhs: not False, rhs: "True", name: Evaluate} - warn: {lhs: Nothing >>= k, rhs: Nothing, name: Evaluate} - warn: {lhs: k =<< Nothing, rhs: Nothing, name: Evaluate} - warn: {lhs: either f g (Left x), rhs: f x, name: Evaluate} - 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: "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} - warn: {lhs: "scanr f z []", rhs: "[z]", name: Evaluate} - 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: "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: "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 - warn: {lhs: "foldr f z (x,b)", rhs: f b z, name: Using foldr on tuple} - warn: {lhs: "foldr' f z (x,b)", rhs: f b z, name: Using foldr' on tuple} - warn: {lhs: "foldl f z (x,b)", rhs: f z b, name: Using foldl on tuple} - warn: {lhs: "foldl' f z (x,b)", rhs: f z b, name: Using foldl' on tuple} - warn: {lhs: "foldMap f (x,b)", rhs: f b, name: Using foldMap on tuple} - warn: {lhs: "foldr1 f (x,b)", rhs: b, name: Using foldr1 on tuple} - warn: {lhs: "foldl1 f (x,b)", rhs: b, name: Using foldl1 on tuple} - warn: {lhs: "elem e (x,b)", rhs: e == b, name: Using elem on tuple} - warn: {lhs: "fold (x,b)", rhs: b, name: Using fold on tuple} - 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: "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: "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} - warn: {lhs: "all f (x,b)", rhs: f b, name: Using all on tuple} - warn: {lhs: "foldr f z (x,y,b)", rhs: f b z, name: Using foldr on tuple} - warn: {lhs: "foldr' f z (x,y,b)", rhs: f b z, name: Using foldr' on tuple} - warn: {lhs: "foldl f z (x,y,b)", rhs: f z b, name: Using foldl on tuple} - warn: {lhs: "foldl' f z (x,y,b)", rhs: f z b, name: Using foldl' on tuple} - warn: {lhs: "foldMap f (x,y,b)", rhs: f b, name: Using foldMap on tuple} - warn: {lhs: "foldr1 f (x,y,b)", rhs: b, name: Using foldr1 on tuple} - warn: {lhs: "foldl1 f (x,y,b)", rhs: b, name: Using foldl1 on tuple} - warn: {lhs: "elem e (x,y,b)", rhs: e == b, name: Using elem on tuple} - warn: {lhs: "fold (x,y,b)", rhs: b, name: Using fold on tuple} - 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: "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: "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} - warn: {lhs: "all f (x,y,b)", rhs: f b, name: Using all on tuple} - 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 imports: - package base - package lens rules: - 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: "(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)"} # `at` pitfalls: - 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"} - 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"} - group: name: use-lens enabled: false imports: - package base - package lens rules: - warn: {lhs: "either Just (const Nothing)", rhs: preview _Left} - 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: - package base - package attoparsec rules: - warn: {lhs: Data.Attoparsec.Text.option Nothing (Just <$> p), rhs: optional p} - 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: - package base rules: - 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 enabled: false imports: - 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} # hints that use the 'extra' library - group: name: extra enabled: false rules: - warn: {lhs: fmap concat (forM a b), rhs: concatForM a b} - warn: {lhs: concat <$> forM a b, rhs: concatForM a b} - warn: {lhs: fmap concat (forM_ a b), rhs: concatForM_ a b} - warn: {lhs: concat <$> forM_ a b, rhs: concatForM_ a b} - warn: {lhs: "maybe (pure ()) b a", rhs: "whenJust a b"} - warn: {lhs: "maybe (return ()) b a", rhs: "whenJust a b"} - warn: {lhs: "maybeM (pure ()) b a", rhs: "whenJustM a b"} - warn: {lhs: "maybeM (return ()) b a", rhs: "whenJustM a b"} - warn: {lhs: "if a then Just <$> b else pure Nothing", rhs: "whenMaybe a b"} - warn: {lhs: "maybe a b =<< c", rhs: "maybeM a b c"} - warn: {lhs: "maybeM a pure x", rhs: "fromMaybeM a b"} - warn: {lhs: "maybeM a return x", rhs: "fromMaybeM a b"} - warn: {lhs: "either a b =<< c", rhs: "eitherM a b c"} - warn: {lhs: "fold1M a b >> 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: "spanEnd (not . a)", rhs: "breakEnd a"} - warn: {lhs: "mconcat (map a b)", rhs: "mconcatMap a b"} - warn: {lhs: "fromMaybe b (stripPrefix a b)", rhs: "dropPrefix a b"} - warn: {lhs: "fromMaybe b (stripSuffix a b)", rhs: "dropSuffix a b"} - warn: {lhs: "nubSortBy compare", rhs: "nubSort"} - warn: {lhs: "nubSortBy (compare `on` a)", rhs: "nubSortOn a"} - warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"} - warn: {lhs: "\\a -> (a, a)", rhs: "dupe"} - warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"} - warn: {lhs: "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: notNull (concat x), rhs: any notNull 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} - hint: {lhs: "\\(x,y) -> (f x, f y)", rhs: both f} # hints that will be enabled in future - group: name: future enabled: false rules: - warn: {lhs: return, rhs: pure} - group: name: dollar enabled: false imports: - package base rules: - 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} - group: name: teaching enabled: false imports: - package base rules: - hint: {lhs: "x /= []", rhs: not (null x), name: Use null} - 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"} # # yes = concat . map f -- concatMap f # yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar # yes = map f (map g x) -- map (f . g) x # yes = concat.map (\x->if x==e then l' else [x]) -- concatMap (\x->if x==e then l' else [x]) # 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 # yes = not (a /= b) -- a == b # yes = not . (a ==) -- (a /=) # yes = not . (== a) -- (/= a) # yes = not . (a /=) -- (a ==) # 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 -- a Data.Functor.<&> bob # yes = return . bob =<< a -- bob <$> a # 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 # yes = pure x <* y -- x Data.Functor.<$ y # yes = return x <* y -- x Data.Functor.<$ y # yes = const x <$> y -- x <$ y # yes = pure alice <$> [1, 2] -- alice <$ [1, 2] # yes = return alice <$> "Bob" -- alice <$ "Bob" # yes = Just a <&> const b -- Just a Data.Functor.$> b # yes = [a,b] <&> pure c -- [a,b] Data.Functor.$> c # yes = Hi <&> return bye -- Hi Data.Functor.$> bye # yes = (x !! 0) + (x !! 2) -- head x # yes = if b < 42 then [a] else [] -- [a | b < 42] # no = take n (foo xs) == "hello" # 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 -- Data.Bifunctor.bimap toUpper urlEncode # yes = map (\(a,b) -> a) xs -- fst # yes = map (\(a,_) -> a) xs -- fst # yes = readFile $ args !! 0 -- head args # yes = if Debug `elem` opts then ["--debug"] else [] -- ["--debug" | Debug `elem` opts] # yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \ # -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True # 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) -- Data.Bifunctor.second ((+) y) # no = foo $ \(a, b) -> (a, a + b) # 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) # no = foo (\ v -> f v . g) # yes = concat . intersperse " " -- unwords # yes = Prelude.concat $ intersperse " " xs -- unwords xs # yes = concat $ Data.List.intersperse " " xs -- unwords xs # yes = if a then True else False -- a # yes = if x then true else False -- x && true # yes = elem x y -- x `elem` y # 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 # 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; 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 # no = [Left x | Left x <- xs] # when p s = if p then s else return () # 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 # main = map (writer,) $ map arcObj $ filter (rdfPredEq (Res dctreferences)) ts -- map ((writer,) . arcObj) (filter (rdfPredEq (Res dctreferences)) ts) # h x y = return $! (x, y) -- return (x, y) # h x y = return $! x # getInt = do { x <- readIO "0"; return $! (x :: Int) } # foo = evaluate [12] -- return [12] # 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 <$> abc 123 # no = fmap lines $ abc $ def 123 # test = foo . not . not -- id # test = map (not . not) xs -- id # used = not . not . any (`notElem` special) . fst . derives -- any (`notElem` special) . fst . derives # test = foo . id . map -- map # test = food id xs # yes = baz baz >> return () -- Control.Monad.void (baz baz) # no = foo >>= bar >>= something >>= elsee >> return () # no = f (#) x # data Pair = P {a :: !Int}; foo = return $! P{a=undefined} # data Pair = P {a :: !Int}; foo = return $! P undefined # foo = return $! Just undefined -- return (Just undefined) # foo = return $! (a,b) -- return (a,b) # foo = return $! 1 # foo = return $! "test" # bar = [x | (x,_) <- pts] # return' x = x `seq` return x # 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) # foo = bar $ \x -> [x,y] # foo = bar $ \x -> [z,y] -- const [z,y] # 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 (`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 # import Control.Monad \ # yes = flip mapM -- forM # import Control.Monad(forM) \ # yes = flip mapM -- forM # import Control.Monad(forM_) \ # yes = flip mapM -- Control.Monad.forM # import qualified Control.Monad \ # yes = flip mapM -- Control.Monad.forM # import qualified Control.Monad as CM \ # yes = flip mapM -- CM.forM # import qualified Control.Monad as CM(forM,filterM) \ # yes = flip mapM -- CM.forM # import Control.Monad as CM(forM,filterM) \ # yes = flip mapM -- forM # import Control.Monad hiding (forM) \ # yes = flip mapM -- Control.Monad.forM # import Control.Monad hiding (filterM) \ # yes = flip mapM -- forM # import qualified Data.Text.Lazy as DTL \ # main = DTL.concat $ map (`DTL.snoc` '-') [DTL.pack "one", DTL.pack "two", DTL.pack "three"] # import Text.Blaze.Html5.Attributes as A \ # main = A.id (stringValue id') # 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 length) -- sortOn length # 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 |] # hlint-3.5/data/hs-lint.el0000644000000000000000000000762307346545000013511 0ustar0000000000000000;;; hs-lint.el --- minor mode for HLint code checking ;; Copyright 2009 (C) Alex Ott ;; ;; Author: Alex Ott ;; Keywords: haskell, lint, HLint ;; Requirements: ;; Status: distributed under terms of GPL2 or above ;; Typical message from HLint looks like: ;; ;; /Users/ott/projects/lang-exp/haskell/test.hs:52:1: Eta reduce ;; Found: ;; count1 p l = length (filter p l) ;; Perhaps: ;; count1 p = length . filter p (require 'compile) (defgroup hs-lint nil "Run HLint as inferior of Emacs, parse error messages." :group 'tools :group 'haskell) (defcustom hs-lint-command "hlint" "The default hs-lint command for \\[hlint]." :type 'string :group 'hs-lint) (defcustom hs-lint-save-files t "Save modified files when run HLint or no (ask user)" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-with-suggestions nil "Replace user's code with suggested replacements" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-without-ask nil "Replace user's code with suggested replacements automatically" :type 'boolean :group 'hs-lint) (defun hs-lint-process-setup () "Setup compilation variables and buffer for `hlint'." (run-hooks 'hs-lint-setup-hook)) ;; regex for replace suggestions ;; ;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .* ;; Found: ;; \s +\(.*\) ;; Perhaps: ;; \s +\(.*\) (defvar hs-lint-regex "^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Perhaps:[\n\C-m]\\s +\\(.*\\)[\n\C-m]" "Regex for HLint messages") (defun make-short-string (str maxlen) (if (< (length str) maxlen) str (concat (substring str 0 (- maxlen 3)) "..."))) (defun hs-lint-replace-suggestions () "Perform actual replacement of suggestions" (goto-char (point-min)) (while (re-search-forward hs-lint-regex nil t) (let* ((fname (match-string 1)) (fline (string-to-number (match-string 2))) (old-code (match-string 4)) (new-code (match-string 5)) (msg (concat "Replace '" (make-short-string old-code 30) "' with '" (make-short-string new-code 30) "'")) (bline 0) (eline 0) (spos 0) (new-old-code "")) (save-excursion (switch-to-buffer (get-file-buffer fname)) (goto-line fline) (beginning-of-line) (setf bline (point)) (when (or hs-lint-replace-without-ask (yes-or-no-p msg)) (end-of-line) (setf eline (point)) (beginning-of-line) (setf old-code (regexp-quote old-code)) (while (string-match "\\\\ " old-code spos) (setf new-old-code (concat new-old-code (substring old-code spos (match-beginning 0)) "\\ *")) (setf spos (match-end 0))) (setf new-old-code (concat new-old-code (substring old-code spos))) (remove-text-properties bline eline '(composition nil)) (when (re-search-forward new-old-code eline t) (replace-match new-code nil t))))))) (defun hs-lint-finish-hook (buf msg) "Function, that is executed at the end of HLint execution" (if hs-lint-replace-with-suggestions (hs-lint-replace-suggestions) (next-error 1 t))) (define-compilation-mode hs-lint-mode "HLint" "Mode for check Haskell source code." (set (make-local-variable 'compilation-process-setup-function) 'hs-lint-process-setup) (set (make-local-variable 'compilation-disable-input) t) (set (make-local-variable 'compilation-scroll-output) nil) (set (make-local-variable 'compilation-finish-functions) (list 'hs-lint-finish-hook)) ) (defun hs-lint () "Run HLint for current buffer with haskell source" (interactive) (save-some-buffers hs-lint-save-files) (compilation-start (concat hs-lint-command " \"" buffer-file-name "\"") 'hs-lint-mode)) (provide 'hs-lint) ;;; hs-lint.el ends here hlint-3.5/data/import_style.yaml0000644000000000000000000000054007346545000015216 0ustar0000000000000000- 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} hlint-3.5/data/report_template.html0000644000000000000000000001007207346545000015675 0ustar0000000000000000 HLint Report

All hints

    $HINTS

All files

    $FILES

Report generated by HLint $VERSION - a tool to suggest improvements to your Haskell code.

$CONTENT
hlint-3.5/data/test-restrict.yaml0000644000000000000000000000112007346545000015273 0ustar0000000000000000- 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" hlint-3.5/data/wildcards.yaml0000644000000000000000000000103207346545000014435 0ustar0000000000000000- 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-3.5/hlint.cabal0000644000000000000000000001042707346545000012776 0ustar0000000000000000cabal-version: 1.18 build-type: Simple name: hlint version: 3.5 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell copyright: Neil Mitchell 2006-2022 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code. homepage: https://github.com/ndmitchell/hlint#readme bug-reports: https://github.com/ndmitchell/hlint/issues data-dir: data data-files: hlint.yaml default.yaml Test.hs report_template.html hs-lint.el hlint.1 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==9.2, GHC==9.0 source-repository head type: git location: https://github.com/ndmitchell/hlint.git flag threaded default: True manual: True description: Build with support for multithreaded execution flag gpl default: True 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, uniplate >= 1.5, ansi-terminal >= 0.8.1, extra >= 1.7.3, refact >= 0.3, aeson >= 1.3, deriving-aeson >= 0.2, filepattern >= 0.1.1 if !flag(ghc-lib) && impl(ghc >= 9.4.1) && impl(ghc < 9.5.0) build-depends: ghc == 9.4.*, ghc-boot-th, ghc-boot else build-depends: ghc-lib-parser == 9.4.* build-depends: ghc-lib-parser-ex >= 9.4.0.0 && < 9.4.1 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 other-modules: Paths_hlint Apply CmdLine Extension Fixity HLint HsColour Idea Report Util Parallel Refact Timing CC EmbedData Summary Config.Compute Config.Haskell Config.Read Config.Type Config.Yaml GHC.All GHC.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 Hint.ListRec Hint.Match Hint.Monad Hint.Naming Hint.NewType Hint.Pattern Hint.Pragma Hint.Restrict Hint.Smell Hint.Type Hint.Unsafe Hint.NumLiteral Test.All Test.Annotations Test.InputOutput Test.Util ghc-options: -Wunused-binds -Wunused-imports -Worphans executable hlint default-language: Haskell2010 build-depends: base, hlint main-is: src/Main.hs -- 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 hlint-3.5/src/0000755000000000000000000000000007346545000011457 5ustar0000000000000000hlint-3.5/src/Apply.hs0000644000000000000000000001316007346545000013101 0ustar0000000000000000 module Apply(applyHints, applyHintFile, applyHintFiles) where import Control.Applicative import Data.Monoid import GHC.All import Hint.All import GHC.Util import Data.Generics.Uniplate.DataOnly import Idea import Data.Tuple.Extra import Data.Either import Data.List.Extra import Data.Maybe import Data.Ord import Config.Type import Config.Haskell import GHC.Types.SrcLoc import GHC.Hs import Language.Haskell.GhclibParserEx.GHC.Hs import qualified Data.HashSet as Set import Prelude import Util -- | 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 pure $ case res of Left err -> [err] Right m -> 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 pure $ err ++ executeHints s ms -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. -- 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 {- PUBLIC -} :: [Classify] -> Hint -> [ModuleEx] -> [Idea] applyHints cs = applyHintsReal $ map SettingClassify cs applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] applyHintsReal settings hints_ ms = concat $ [ map (classify classifiers . removeRequiresExtensionNotes m) $ order [] (hintModule hints settings nm m) `merge` 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 $ 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 (\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 :: ModuleEx -> Idea -> Idea removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x} where exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas (comments (hsmodAnn (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] -> [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 ModuleEx) parseModuleApply flags s file src = do res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src case res of 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 where builtin = nubOrd $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs] f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints -- | 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} 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 | otherwise = r x ~= y = x == "" || any (wildcardMatch x) y x ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y) hlint-3.5/src/CC.hs0000644000000000000000000000753307346545000012310 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | -- -- Utility for formatting @'Idea'@ data in accordance with the Code Climate -- spec: -- module CC ( printIssue , fromIdea ) where import Data.Aeson (ToJSON(..), (.=), encode, object) import Data.Char (toUpper) import Data.Text (Text) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as C8 import Idea (Idea(..), Severity(..)) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Util as GHC data Issue = Issue { issueType :: Text , issueCheckName :: Text , issueDescription :: Text , issueContent :: Text , issueCategories :: [Text] , issueLocation :: Location , issueRemediationPoints :: Int } data Location = Location FilePath Position Position data Position = Position Int Int instance ToJSON Issue where toJSON Issue{..} = object [ "type" .= issueType , "check_name" .= issueCheckName , "description" .= issueDescription , "content" .= object [ "body" .= issueContent ] , "categories" .= issueCategories , "location" .= issueLocation , "remediation_points" .= issueRemediationPoints ] instance ToJSON Location where toJSON (Location path begin end) = object [ "path" .= path , "positions" .= object [ "begin" .= begin , "end" .= end ] ] instance ToJSON Position where toJSON (Position line column) = object [ "line" .= line , "column" .= column ] -- | Print an @'Issue'@ with trailing null-terminator and newline -- -- The trailing newline will be ignored, but makes the output more readable -- printIssue :: Issue -> IO () printIssue = C8.putStrLn . (<> "\0") . encode -- | Convert an hlint @'Idea'@ to a datatype more easily serialized for CC fromIdea :: Idea -> Issue fromIdea Idea{..} = Issue { issueType = "issue" , issueCheckName = "HLint/" <> T.pack (camelize ideaHint) , issueDescription = T.pack ideaHint , issueContent = content ideaFrom ideaTo <> listNotes ideaNote , issueCategories = categories ideaHint , issueLocation = fromSrcSpan ideaSpan , issueRemediationPoints = points ideaSeverity } where content from Nothing = T.unlines [ "Found" , "" , "```" , T.pack from , "```" , "" , "remove it." ] content from (Just to) = T.unlines [ "Found" , "" , "```" , T.pack from , "```" , "" , "Perhaps" , "" , "```" , T.pack to , "```" ] listNotes [] = "" listNotes notes = T.unlines $ [ "" , "Applying this change:" , "" ] ++ map (("* " <>) . T.pack . show) notes categories _ = ["Style"] points Ignore = 0 points Suggestion = basePoints points Warning = 5 * basePoints points Error = 10 * basePoints fromSrcSpan :: GHC.SrcSpan -> Location fromSrcSpan GHC.SrcSpan{..} = Location (locationFileName srcSpanFilename) (Position srcSpanStartLine' srcSpanStartColumn) (Position srcSpanEndLine' srcSpanEndColumn) where locationFileName ('.':'/':x) = x locationFileName x = x camelize :: String -> String camelize = concatMap capitalize . words capitalize :: String -> String capitalize [] = [] capitalize (c:rest) = toUpper c : rest -- "The baseline remediation points value is 50,000, which is the time it takes -- to fix a trivial code style issue like a missing semicolon on a single line, -- including the time for the developer to open the code, make the change, and -- confidently commit the fix. All other remediation points values are expressed -- in multiples of that Basic Remediation Point Value." basePoints :: Int basePoints = 50000 hlint-3.5/src/CmdLine.hs0000644000000000000000000003745607346545000013345 0ustar0000000000000000{-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-} {-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-} module CmdLine( Cmd(..), getCmd, CppFlags(..), cmdCpp, cmdExtensions, cmdHintFiles, cmdUseColour, exitWithHelp, resolveFile ) where import Control.Monad.Extra import Control.Exception.Extra import qualified Data.ByteString as BS import Data.Char import Data.List.Extra import Data.Maybe import Data.Functor 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(hSupportsANSIWithoutEmulation) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) import System.Console.CmdArgs.Implicit import System.Directory.Extra import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Error 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 getCmd args = withArgs (map f args) $ automatic =<< cmdArgsRun mode where f x = if x == "-?" || x == "--help" then "--help=all" else x automatic :: Cmd -> IO Cmd automatic cmd = dataDir =<< path =<< git =<< extension cmd where 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 /= "" = pure cmd | otherwise = do x <- getDataDir b <- doesDirectoryExist x if b then pure cmd{cmdDataDir=x} else do exe <- getExecutablePath pure cmd{cmdDataDir = takeDirectory exe "data"} git cmd | cmdGit cmd = do mgit <- findExecutable "git" case mgit of Nothing -> errorIO "Could not find git" Just git -> do let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++ map ("*." ++) (cmdExtension cmd) files <- timedIO "Execute" (unwords $ git:args) $ readProcess git args "" pure cmd{cmdFiles = cmdFiles cmd ++ lines files} | otherwise = pure cmd exitWithHelp :: IO a exitWithHelp = do putStr $ show $ helpText [] HelpFormatAll mode exitSuccess -- | When to colour terminal output. 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. deriving (Show, Typeable, Data) instance Default ColorMode where 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 ,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 ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,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 ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in ,cmdDataDir :: FilePath -- ^ the data directory ,cmdDefault :: Bool -- ^ Print a default file to stdout ,cmdPath :: [String] ,cmdCppDefine :: [String] ,cmdCppInclude :: [FilePath] ,cmdCppFile :: [FilePath] ,cmdCppSimple :: Bool ,cmdCppAnsi :: Bool ,cmdJson :: Bool -- ^ display hint data as JSON ,cmdCC :: Bool -- ^ display hint data as Code Climate Issues ,cmdNoSummary :: Bool -- ^ do not show the summary info ,cmdOnly :: [String] -- ^ specify which hints explicitly ,cmdNoExitCode :: Bool ,cmdTiming :: Bool ,cmdSerialise :: Bool -- ^ Display hints in serialisation format ,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 ,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) mode = cmdArgsMode $ modes [CmdMain {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" ,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 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" ,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" ,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file" ,cmdDataDir = nam_ "datadir" &= typDir &= help "Override the data directory" ,cmdDefault = nam "default" &= help "Print a default file to stdout" ,cmdPath = nam "path" &= help "Directory in which to search for files" ,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define" ,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path" ,cmdCppFile = nam_ "cpp-file" &= typFile &= help "CPP pre-include file" ,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)" ,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" ,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" ,cmdTiming = nam_ "timing" &= help "Display timing information" ,cmdSerialise = nam_ "serialise" &= help "Serialise hint data for consumption by apply-refact" ,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 Mardown 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" &= 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"] ] &= program "hlint" &= verbosity &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2022") where nam xs = nam_ xs &= name [head xs] nam_ xs = def &= explicit &= name xs -- | Where should we find the configuration files? -- Either we use the implicit search, or we follow the cmdGivenHints -- We want more important hints to go last, since they override cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)] cmdHintFiles cmd = do let explicit = cmdGivenHints cmd bad <- filterM (notM . doesFileExist) explicit when (bad /= []) $ fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad -- 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 $ pure []) findM doesFileExist $ map ( ".hlint.yaml") (ancestors curdir ++ home) -- to match Stylish Haskell pure $ hlintYaml : map (,Nothing) (maybeToList implicit ++ explicit) where ancestors = init . map joinPath . reverse . inits . splitPath cmdExtensions :: Cmd -> (Maybe Language, ([Extension], [Extension])) cmdExtensions = getExtensions . cmdLanguage cmdCpp :: Cmd -> CppFlags cmdCpp cmd | cmdCppSimple cmd = CppSimple | otherwise = Cpphs defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd} ,includes = cmdCppInclude cmd ,preInclude = cmdCppFile cmd ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] } -- | Determines whether to use colour or not. cmdUseColour :: Cmd -> IO Bool cmdUseColour cmd = case cmdColor cmd of Always -> pure True Never -> pure False Auto -> do supportsANSI <- hSupportsANSIWithoutEmulation stdout pure $ Just True == supportsANSI "." <\> x = x x <\> y = x y resolveFile :: Cmd -> Maybe FilePath -- ^ Temporary file -> FilePath -- ^ File to resolve, may be "-" for stdin -> IO [FilePath] 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 -> 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 >> 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 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 pure [p <\> file] else do res <- getModule p exts file case res of Just x -> pure [x] Nothing -> getFile ignore ath exts t file getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath) getModule path exts x | not (any isSpace x) && all isMod xs = f exts where xs = words $ map (\x -> if x == '.' then ' ' else x) x isMod (x:xs) = isUpper x && all (\x -> isAlphaNum x || x == '_') xs isMod _ = False pre = path <\> joinPath xs f [] = pure Nothing f (x:xs) = do let s = pre <.> x b <- doesFileExist s if b then pure $ Just s else f xs getModule _ _ _ = pure Nothing 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 <- [Haskell98, Haskell2010 , GHC2021] ] 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 ++ "'" 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] hlint-3.5/src/Config/0000755000000000000000000000000007346545000012664 5ustar0000000000000000hlint-3.5/src/Config/Compute.hs0000644000000000000000000000654507346545000014646 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -- | Given a file, guess settings from it by looking at the hints. module Config.Compute(computeSettings) where import GHC.All import GHC.Util import Config.Type import Fixity import Data.Generics.Uniplate.DataOnly import GHC.Hs hiding (Warning) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Data.Bag 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 -- | Given a source file, guess some hints that might apply. -- Returns the text of the hints (if you want to save it down) along with the settings to be used. computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting]) computeSettings flags file = do x <- parseModuleEx flags file Nothing case x of Left (ParseError sl msg _) -> 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 (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"] renderSetting (Infix x) = ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)] renderSetting _ = [] findSetting :: LocatedA (HsDecl GhcPs) -> [Setting] findSetting (L _ (ValD _ x)) = findBind x findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) = concatMap (findBind . unLoc) $ bagToList cid_binds findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x findSetting x = [] findBind :: HsBind GhcPs -> [Setting] findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches findBind _ = [] findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting] findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]}) = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else [] where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats] findExp name vs HsLam{} = [] findExp name vs HsVar{} = [] findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ HsApp EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint" findExp name vs bod = [SettingMatchExp $ HintRule Warning defaultHintName [] mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing] where lhs = fromParen $ noLocA $ transform f bod rhs = apps $ map noLocA $ HsVar noExtField (noLocA name) : map snd rep 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 EpAnnNotUsed x $ nlHsPar y f x = x mkVar :: String -> HsExpr GhcPs mkVar = HsVar noExtField . noLocA . Unqual . mkVarOcc hlint-3.5/src/Config/Haskell.hs0000644000000000000000000000617007346545000014607 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Config.Haskell( readPragma, readComment ) where import Data.Char import Data.List.Extra import Text.Read import Data.Tuple.Extra import Data.Maybe import Config.Type import Util import Prelude import GHC.Util 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 qualified GHC.Data.Strict 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 :: AnnDecl GhcPs -> Maybe Classify readPragma (HsAnnotation _ _ provenance expr) = f expr where 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 expr "bad classify pragma" Just severity -> Just $ Classify severity (trimStart b) "" name where (a,b) = break isSpace $ trimStart $ drop 6 s f (L _ (HsPar _ _ x _)) = f x f (L _ (ExprWithTySig _ x _)) = f x f _ = Nothing 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 <- if x == "" then Just "" else readMaybe x = map (Classify sev hint "") $ ["" | null things] ++ things f hash _ = errorOnComment c $ "bad HLINT pragma, expected:\n {-" ++ h ++ " HLINT \"Hint name\" " ++ h ++ "-}" where h = ['#' | hash] g x | (s, x) <- word1 x , s /= "" , not $ "\"" `isPrefixOf` s = first ((if s == "module" then "" else s):) $ g x g x = ([], x) readComment _ = [] errorOn :: Outputable a => LocatedA a -> String -> b errorOn (L pos val) msg = exitMessageImpure $ showSrcSpan (locA pos) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ unsafePrettyPrint val errorOnComment :: LEpaComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in showSrcSpan (RealSrcSpan (anchor s) GHC.Data.Strict.Nothing) ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "") hlint-3.5/src/Config/Read.hs0000644000000000000000000000145207346545000014075 0ustar0000000000000000 module Config.Read(readFilesConfig) where import Config.Type import Control.Monad import Control.Exception.Extra import Config.Yaml import Data.List.Extra import System.FilePath readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting] readFilesConfig files = do 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" ++ " " yaml <- mapM (uncurry readFileConfigYaml) yaml pure $ settingsFromConfigYaml yaml hlint-3.5/src/Config/Type.hs0000644000000000000000000001670307346545000014150 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Config.Type( Severity(..), Classify(..), HintRule(..), Note(..), Setting(..), Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..), RestrictImportStyle(..), QualifiedStyle(..), defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType ) where import Data.Char import Data.List.Extra import Data.Monoid import Prelude import qualified GHC.Hs 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 getSeverity "warning" = Just Warning getSeverity "suggest" = Just Suggestion getSeverity "suggestion" = Just Suggestion getSeverity "error" = Just Error getSeverity "hint" = Just Suggestion getSeverity _ = Nothing getRestrictType :: String -> Maybe RestrictType getRestrictType "modules" = Just RestrictModule getRestrictType "extensions" = Just RestrictExtension getRestrictType "flags" = Just RestrictFlag getRestrictType "functions" = Just RestrictFunction getRestrictType _ = Nothing defaultHintName :: String defaultHintName = "Use alternative" -- | How severe an issue is. data Severity = 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. 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 isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x isUnifyVar [] = False isUnifyVar xs = all (== '?') xs --------------------------------------------------------------------- -- TYPE -- | A note describing the impact of the replacement. data Note = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier. | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter. | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@. | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if -- the @x@ variable has a reflexive @Eq@ instance. | RequiresExtension String -- ^ The replacement requires this extension to be available. | Note String -- ^ An arbitrary note. deriving (Eq,Ord) instance Show Note where show IncreasesLaziness = "increases laziness" show DecreasesLaziness = "decreases laziness" show (RemovesError x) = "removes error " ++ x show (ValidInstance x y) = "requires a valid `" ++ x ++ "` instance for `" ++ y ++ "`" show (RequiresExtension x) = "may require `{-# LANGUAGE " ++ x ++ " #-}` adding to the top of the file" show (Note x) = x showNotes :: [Note] -> String showNotes = intercalate ", " . map show . filter use where use ValidInstance{} = False -- Not important enough to tell an end user use _ = True -- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything. data Classify = Classify {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to. ,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'. ,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'. ,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'. } deriving Show -- | A @LHS ==> RHS@ style hint rule. data HintRule = HintRule {hintRuleSeverity :: Severity -- ^ Default severity for the hint. ,hintRuleName :: String -- ^ Name for the hint. ,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 deriving (Show,Eq,Ord) getSmellType :: String -> Maybe SmellType getSmellType "long functions" = Just SmellLongFunctions getSmellType "long type lists" = Just SmellLongTypeLists getSmellType "many arg functions" = Just SmellManyArgFunctions getSmellType "many imports" = Just SmellManyImports getSmellType _ = Nothing data Setting = SettingClassify Classify | SettingMatchExp HintRule | SettingRestrict Restrict | SettingArgument String -- ^ Extra command-line argument | SettingSmell SmellType Int | Builtin String -- use a builtin hint set | Infix FixityInfo deriving Show hlint-3.5/src/Config/Yaml.hs0000644000000000000000000004217307346545000014131 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-} module Config.Yaml( ConfigYaml, ConfigYamlBuiltin (..), ConfigYamlUser (..), readFileConfigYaml, 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.Either.Extra import Data.Maybe import Data.List.Extra import Data.Tuple.Extra import Control.Monad.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 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 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 qualified Data.ByteString 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 -> 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 -> pure v isBuiltinYaml :: FilePath -> Bool isBuiltinYaml = (== "data/hlint.yaml") --------------------------------------------------------------------- -- YAML DATA TYPE newtype ConfigYaml = ConfigYaml [ConfigItem] deriving (Semigroup,Monoid,Show) data ConfigItem = ConfigPackage Package | ConfigGroup Group | ConfigSetting [Setting] deriving Show data Package = Package {packageName :: String ,packageModules :: [HsExtendInstances (LImportDecl GhcPs)] } deriving Show data Group = Group {groupName :: String ,groupEnabled :: Bool ,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))] ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty } deriving Show --------------------------------------------------------------------- -- YAML PARSING LIBRARY data Val = Val Value -- the actual value I'm focused on [(String, Value)] -- the path of values I followed (for error messages) newVal :: Value -> Val newVal x = Val x [("root", x)] getVal :: Val -> Value getVal (Val x _) = x addVal :: String -> Value -> Val -> Val addVal key v (Val focus path) = Val v $ (key,v) : path -- | Failed when parsing some value, give an informative error message. parseFail :: Val -> String -> Parser a parseFail (Val focus path) msg = fail $ "Error when decoding YAML, " ++ msg ++ "\n" ++ "Along path: " ++ unwords steps ++ "\n" ++ "When at: " ++ fst (word1 $ show focus) ++ "\n" ++ -- 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 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 $ 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) = pure (toHashMapText x) parseObject v = parseFail v "Expected an Object" parseObject1 :: Val -> Parser (String, Val) parseObject1 v = do mp <- parseObject v case Map.keys mp of [T.unpack -> s] -> (s,) <$> parseField s v _ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp) parseString :: Val -> Parser String parseString (getVal -> String x) = pure $ T.unpack x parseString v = parseFail v "Expected a String" parseInt :: Val -> Parser Int parseInt (getVal -> s@Number{}) = parseJSON s parseInt v = parseFail v "Expected an Int" 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) = pure b parseBool v = parseFail v "Expected a Bool" parseField :: String -> Val -> Parser Val parseField s v = do x <- parseFieldOpt s v case x of Nothing -> parseFail v $ "Expected a field named " ++ s 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 -> 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 ++ ", Allowed keys: " ++ unwords allow parseGHC :: (ParseFlags -> String -> ParseResult v) -> Val -> Parser v parseGHC parser v = do x <- parseString v case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of POk _ x -> pure x PFailed ps -> let errMsg = head . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps) msg = showSDoc baseDynFlags $ pprLocMsgEnvelope errMsg in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x --------------------------------------------------------------------- -- YAML TO DATA TYPE newtype ConfigYamlBuiltin = ConfigYamlBuiltin { getConfigYamlBuiltin :: ConfigYaml } deriving (Semigroup, Monoid) 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 -> do (s, v) <- parseObject1 o case s of "package" -> ConfigPackage <$> parsePackage 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 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" parsePackage :: Val -> Parser Package parsePackage v = do packageName <- parseField "name" v >>= parseString packageModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode) allowFields v ["name","modules"] pure Package{..} parseFixity :: Val -> Parser [Setting] parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f) where f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x f _ = parseFail v "Expected fixity declaration" parseSmell :: Val -> Parser [Setting] parseSmell v = do smellName <- parseField "type" v >>= parseString smellType <- require v "Expected SmellType" $ getSmellType smellName smellLimit <- parseField "limit" v >>= parseInt pure [SettingSmell smellType smellLimit] where require :: Val -> String -> Maybe a -> Parser a require _ _ (Just a) = pure a require val err Nothing = parseFail val err parseGroup :: Bool -> Val -> Parser Group parseGroup isBuiltin v = do groupName <- parseField "name" v >>= parseString 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"] pure Group{..} where parseImport v = do x <- parseString v case word1 x of ("package", x) -> pure $ Left x _ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] parseRule :: Bool -> Val -> Parser [Either HintRule Classify] parseRule isBuiltin v = do (severity, v) <- parseSeverityKey v isRule <- isJust <$> parseFieldOpt "lhs" v if isRule then do 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 pure $ Left HintRule {hintRuleSeverity = severity, hintRuleLHS = extendInstances lhs, hintRuleRHS = extendInstances rhs, ..} : [Right $ Classify severity hintRuleName "" "" | not isBuiltin] else do 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 def <- parseFieldOpt "default" v case def of Just def -> do b <- parseBool def allowFields v ["default"] pure $ Restrict restrictType b [] mempty mempty mempty mempty [] NoRestrictIdents Nothing Nothing -> do 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 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 -> pure (sev, v) _ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s 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 :: LHsExpr GhcPs -> [String] f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = occNameStr x, not $ isUnifyVar y, y /= "."] asNote :: String -> Note asNote "IncreasesLaziness" = IncreasesLaziness asNote "DecreasesLaziness" = DecreasesLaziness asNote (word1 -> ("RemovesError",x)) = RemovesError x asNote (word1 -> ("ValidInstance",x)) = uncurry ValidInstance $ word1 x asNote (word1 -> ("RequiresExtension",x)) = RequiresExtension x asNote x = Note x --------------------------------------------------------------------- -- SETTINGS settingsFromConfigYaml :: [ConfigYaml] -> [Setting] settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f groups where packages = [x | ConfigPackage x <- configs] groups = [x | ConfigGroup x <- configs] settings = concat [x | ConfigSetting x <- configs] 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' (map (fmap unextendInstances) groupImports) asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope asScope' packages xs = scopeCreate (HsModule EpAnnNotUsed NoLayoutInfo Nothing Nothing (concatMap f xs) [] Nothing Nothing) where f (Right x) = [x] f (Left x) | Just pkg <- Map.lookup x packages = pkg | otherwise = error $ "asScope' failed to do lookup, " ++ x hlint-3.5/src/EmbedData.hs0000644000000000000000000000115107346545000013617 0ustar0000000000000000{-# 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") hlint-3.5/src/Extension.hs0000644000000000000000000000542007346545000013770 0ustar0000000000000000module Extension( defaultExtensions, configExtensions, extensionImpliedEnabledBy, extensionImplies ) where import Data.List.Extra import qualified Data.Map as Map import GHC.LanguageExtensions.Type import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx badExtensions = reallyBadExtensions ++ [ Arrows -- steals proc , UnboxedTuples, UnboxedSums -- breaks (#) lens operator , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break , {- DoRec , -} RecursiveDo -- breaks rec , 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 hlint-3.5/src/Fixity.hs0000644000000000000000000000722407346545000013274 0ustar0000000000000000{-# 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.Types.SourceText import GHC.Parser.Annotation import Language.Haskell.Syntax.Extension 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 NoSourceText i $ f dir) where f LeftAssociative = InfixL f RightAssociative = InfixR f NotAssociative = InfixN fromFixity :: (String, Fixity) -> FixityInfo fromFixity (name, Fixity _ i dir) = (name, assoc dir, i) where assoc dir = case dir of InfixL -> LeftAssociative InfixR -> RightAssociative InfixN -> NotAssociative toFixitySig :: FixityInfo -> FixitySig GhcPs toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [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 ["%%@~","<%@~","%%~","<+~","<*~","<-~","","??"] , 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. hlint-3.5/src/GHC/0000755000000000000000000000000007346545000012060 5ustar0000000000000000hlint-3.5/src/GHC/All.hs0000644000000000000000000002174107346545000013131 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} module GHC.All( CppFlags(..), ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, ParseError(..), ModuleEx(..), parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, 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.Extra import Timing import Language.Preprocessor.Cpphs import System.IO.Extra import Fixity import Extension import GHC.Data.FastString import GHC.Hs 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 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 } -- | 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 . unLoc . ghcModule -- | 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 frorm '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 -> ModuleEx createModuleEx = createModuleExWithFixities (map toFixity defaultFixities) createModuleExWithFixities :: [(String, Fixity)] -> Located HsModule -> ModuleEx createModuleExWithFixities fixities ast = ModuleEx (applyFixities (fixitiesFromModule ast ++ fixities) ast) -- | 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 enableDisableExts = ghcExtensionsFromParseFlags flags -- 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 errs else do let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags pure $ ModuleEx (applyFixities fixes a) PFailed s -> ExceptT $ parseFailureErr dynFlags str file str $ 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 = head errs loc = errMsgSpan errMsg doc = pprLocMsgEnvelope 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) [" "," ","> "," "," "] hlint-3.5/src/GHC/Util.hs0000644000000000000000000000534307346545000013336 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} module GHC.Util ( 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 , fileToModule , pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn , pattern SrcLoc, srcFilename, srcLine, srcColumn , showSrcSpan, ) where import GHC.Util.View import GHC.Util.FreeVars import GHC.Util.ApiAnnotation import GHC.Util.HsExpr import GHC.Util.HsDecl import GHC.Util.SrcLoc import GHC.Util.DynFlags import GHC.Util.Scope import GHC.Util.Unify import Language.Haskell.GhclibParserEx.GHC.Parser (parseFile) import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags) import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import GHC.Hs import GHC.Parser.Lexer import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Data.FastString import System.FilePath import Language.Preprocessor.Unlit fileToModule :: FilePath -> String -> DynFlags -> ParseResult (Located HsModule) fileToModule filename str flags = parseFile filename flags (if takeExtension filename /= ".lhs" then str else unlit filename str) {-# COMPLETE SrcSpan #-} -- | The \"Line'\" thing is because there is already e.g. 'SrcLoc.srcSpanStartLine' pattern SrcSpan :: String -> Int -> Int -> Int -> Int -> SrcSpan pattern SrcSpan { srcSpanFilename , srcSpanStartLine' , srcSpanStartColumn , srcSpanEndLine' , srcSpanEndColumn } <- (toOldeSpan -> ( srcSpanFilename , srcSpanStartLine' , srcSpanStartColumn , srcSpanEndLine' , srcSpanEndColumn )) toOldeSpan :: SrcSpan -> (String, Int, Int, Int, Int) toOldeSpan (RealSrcSpan span _) = ( unpackFS $ srcSpanFile span , srcSpanStartLine span , srcSpanStartCol span , srcSpanEndLine span , srcSpanEndCol span ) -- TODO: the bad locations are all (-1) right now -- is this fine? it should be, since noLoc from HSE previously also used (-1) as an invalid location toOldeSpan (UnhelpfulSpan _) = ( "no-span" , -1 , -1 , -1 , -1 ) {-# COMPLETE SrcLoc #-} pattern SrcLoc :: String -> Int -> Int -> SrcLoc pattern SrcLoc { srcFilename , srcLine , srcColumn } <- (toOldeLoc -> ( srcFilename , srcLine , srcColumn )) toOldeLoc :: SrcLoc -> (String, Int, Int) toOldeLoc (RealSrcLoc loc _) = ( unpackFS $ srcLocFile loc , srcLocLine loc , srcLocCol loc ) toOldeLoc (UnhelpfulLoc _) = ( "no-loc" , -1 , -1 ) showSrcSpan :: SrcSpan -> String showSrcSpan = unsafePrettyPrint hlint-3.5/src/GHC/Util/0000755000000000000000000000000007346545000012775 5ustar0000000000000000hlint-3.5/src/GHC/Util/ApiAnnotation.hs0000644000000000000000000000720207346545000016076 0ustar0000000000000000 module GHC.Util.ApiAnnotation ( comment_, commentText, 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 qualified Data.Set 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 comment_ (L _ (EpaComment EpaEofComment _)) = "" -- | The comment string with delimiters removed. commentText :: LEpaComment -> String commentText = trimCommentDelims . comment_ 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 . mapMaybe readExtension . concatMap 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 he 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 :: Anchor -> [String] -> LEpaComment mkFlags anc flags = L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc) mkLanguagePragmas :: Anchor -> [String] -> LEpaComment mkLanguagePragmas anc exts = L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc) hlint-3.5/src/GHC/Util/Brackets.hs0000644000000000000000000001457207346545000015100 0ustar0000000000000000{-# 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 -- Technically atomic, but lots of people think it shouldn't be HsRecSel{} -> False 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 HsSpliceE{} -> True HsOverLit _ x | not $ isNegativeOverLit x -> True HsLit _ x | not $ isNegativeLit x -> True _ -> False where isNegativeLit (HsInt _ i) = il_neg i isNegativeLit (HsRat _ f _) = fl_neg f isNegativeLit (HsFloatPrim _ f) = fl_neg f isNegativeLit (HsDoublePrim _ f) = fl_neg f isNegativeLit (HsIntPrim _ x) = x < 0 isNegativeLit (HsInt64Prim _ x) = x < 0 isNegativeLit (HsInteger _ x _) = x < 0 isNegativeLit _ = False isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f isNegativeOverLit _ = False isAtom _ = False -- '{-# COMPLETE 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 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 EpAnnNotUsed 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 hlint-3.5/src/GHC/Util/DynFlags.hs0000644000000000000000000000104507346545000015040 0ustar0000000000000000module 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 fakeLlvmConfig initGlobalDynFlags :: IO () initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags hlint-3.5/src/GHC/Util/FreeVars.hs0000644000000000000000000003201407346545000015046 0ustar0000000000000000{-# 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 GHC.Data.Bag (bagToList) import Data.Generics.Uniplate.DataOnly import Data.Monoid import Data.Semigroup import Data.List.Extra import Data.Set (Set) import qualified Data.Set as Set import Prelude ( ^+ ) :: Set OccName -> Set OccName -> Set OccName ( ^+ ) = Set.union ( ^- ) :: Set OccName -> Set OccName -> Set OccName ( ^- ) = Set.difference -- See [Note : 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 varaiable -- sets in a value of `a`. class AllVars a where -- | Return the variables, erring on the side of more free -- variables. allVars :: a -> Vars -- A type `a` is a model of `FreeVars a` if exists a function -- `freeVars` for producing a set of free varaiable of a value of -- `a`. class FreeVars a where -- | Return the variables, erring on the side of more free -- variables. freeVars :: a -> Set OccName -- Trivial instances. instance AllVars Vars where allVars = id instance FreeVars (Set OccName) where freeVars = id -- [Note : Space leaks lurking here?] -- ================================== -- We make use of `foldr`. @cocreature suggests we want bangs on `data -- Vars` and replace usages of `mconcat` with `foldl`. instance (AllVars a) => AllVars [a] where allVars = 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 [x] -- Unbound variable; also used for "holes". freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match. freeVars (L _ (HsLamCase _ _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr. freeVars (L _ (HsLet _ _ binds _ e)) = inFree binds e -- Let (rec). freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block. freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction. freeVars (L _ (RecordUpd _ e flds)) = case flds of Left fs -> Set.unions $ freeVars e : map freeVars fs Right 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 _ HsRecSel{}) = mempty -- Variable pointing to a record selector. freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel. freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter. freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal. freeVars (L _ HsLit{}) = mempty -- Simple literal. -- freeVars (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 (LocatedAn NoEpAnns (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 (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where freeVars (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 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 (LocatedAn NoEpAnns (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 _ ApplicativeStmt{}) = mempty -- Generated by the renamer. allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it. instance AllVars (HsLocalBinds GhcPs) where allVars (HsValBinds _ (ValBinds _ binds _)) = allVars (bagToList 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) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss 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 pats <> allVars grhss -- A pattern matching on an argument of a function binding. allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc. allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else. instance AllVars (HsStmtContext GhcPs) 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 hlint-3.5/src/GHC/Util/HsDecl.hs0000644000000000000000000000275407346545000014503 0ustar0000000000000000{-# 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 hlint-3.5/src/GHC/Util/HsExpr.hs0000644000000000000000000003240307346545000014544 0ustar0000000000000000{-# 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.Data.Bag(bagToList) import GHC.Util.Brackets import GHC.Util.FreeVars import GHC.Util.View import Control.Applicative 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 qualified Refact.Types as R (SrcSpan) import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances 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 EpAnnNotUsed 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 noExtField (MG noExtField (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]) Generated) -- | '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 EpAnnNotUsed 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)) = liftA2 (\x y -> L l $ HsApp EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed x (nlHsPar y)) simplifyExp e@(L _ (HsLet _ _ ((HsValBinds _ (ValBinds _ binds []))) _ z)) = -- An expression of the form, 'let x = y in z'. case bagToList binds of [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (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 EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed (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 EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField} match = noLocA $ Match {m_ext=EpAnnNotUsed, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs) matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLocA [match]} in (noLocA $ HsLam noExtField matchGroup, const []) -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs) replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf EpAnnNotUsed a b c)) replaceBranches (L s (HsCase _ a (MG _ (L l bs) FromSource))) = (concatMap f bs, \xs -> L s (HsCase EpAnnNotUsed a (MG noExtField (L l (g bs xs)) Generated))) 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 EpAnnNotUsed CaseAlt a (GRHSs emptyComments [L a (GRHS EpAnnNotUsed 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 hlint-3.5/src/GHC/Util/Scope.hs0000644000000000000000000001320207346545000014400 0ustar0000000000000000 {-# 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.Unit.Module 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 -- 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 -> 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 declaraions 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 declaraion 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 (ideclHiding i) else NotImported where f :: (Bool, LocatedL [LIE 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 _wildcard ys)) = Just $ tag `elem` unwrapName y : map unwrapName ys g _ = Just False unwrapName :: LIEWrappedName RdrName -> String unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x)) possImport _ _ = NotImported hlint-3.5/src/GHC/Util/SrcLoc.hs0000644000000000000000000000432607346545000014523 0ustar0000000000000000{-# 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 qualified GHC.Data.Strict import Data.Default import Data.Data import Data.Generics.Uniplate.DataOnly -- Get the 'SrcSpan' out of a value located by an 'Anchor' (e.g. -- comments). getAncLoc :: GenLocated Anchor a -> SrcSpan getAncLoc o = RealSrcSpan (anchor (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 hlint-3.5/src/GHC/Util/Unify.hs0000644000000000000000000003266407346545000014436 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} 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 -- Peform a substition. -- 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 substituation 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 EpAnnNotUsed lhs y rhs)) -- Left sections. exp (L loc (SectionL _ exp (L _ (HsVar _ x)))) | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL EpAnnNotUsed exp y)) -- Right sections. exp (L loc (SectionR _ (L _ (HsVar _ x)) exp)) | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR EpAnnNotUsed 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 AnnsModule) <- cast x = Just mempty | Just (x :: EpAnn NameAnn) <- cast x = Just mempty | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty | Just (x :: EpAnn AnnList) <- cast x = Just mempty | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty | Just (x :: EpAnn AnnContext) <- cast x = Just mempty | Just (x :: EpAnn AnnParen) <- cast x = Just mempty | Just (x :: EpAnn Anchor) <- cast x = Just mempty | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty | Just (x :: EpAnn GrhsAnn) <- cast x = Just mempty | Just (x :: EpAnn [AddEpAnn]) <- cast x = Just mempty | Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty | Just (x :: EpAnn EpAnnUnboundVar) <- cast x = Just mempty | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty | Just (x :: EpAnn AnnProjection) <- cast x = Just mempty | Just (x :: EpAnn Anchor) <- cast x = Just mempty | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty | Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty | Just (x :: EpAnn AnnSig) <- cast x = Just mempty | Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty | Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty | Just (x :: EpAnn (AddEpAnn, AddEpAnn)) <- cast x = Just mempty | Just (x :: EpAnn AnnsIf) <- 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 EpAnnNotUsed 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 EpAnnNotUsed y11 (noLocA (HsApp EpAnnNotUsed 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 EpAnnNotUsed lhs2 rhs2) | isAmp op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed rhs2 lhs2) | otherwise = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed (noLocA (HsApp EpAnnNotUsed 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 subsitute 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__" :: LHsExpr GhcPs appType = L loc (HsAppType noSrcSpan unused wc) :: LHsExpr GhcPs in Just $ Subst [(rdrNameStr x, appType)] unifyType' nm x y = unifyDef' nm x y hlint-3.5/src/GHC/Util/View.hs0000644000000000000000000000473007346545000014247 0ustar0000000000000000{-# 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 _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}] (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]) FromSource)))) = 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 _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))]) _)) hlint-3.5/src/HLint.hs0000644000000000000000000002172507346545000013040 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module HLint(hlint, readAllSettings) where import Control.Applicative import Control.Monad.Extra 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 Prelude 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 Refact import Timing import Parallel import GHC.All import CC import EmbedData -- | 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. -- This function writes to the stdout/stderr streams, unless @--quiet@ is specified. -- -- As an example: -- -- > do hints <- hlint ["src", "--ignore=Use map","--quiet"] -- > when (length hints > 3) $ error "Too many hints!" -- -- /Warning:/ The flags provided by HLint are relatively stable, but do not have the same -- API stability guarantees as the rest of the strongly-typed API. Do not run this function -- on your server with untrusted input. hlint :: [String] -> IO [Idea] hlint args = do startTimings cmd <- getCmd args 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@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} withVerbosity :: Verbosity -> IO a -> IO a withVerbosity new act = do old <- getVerbosity (setVerbosity new >> act) `finally` setVerbosity old hlintMain :: [String] -> Cmd -> IO [Idea] hlintMain args cmd@CmdMain{..} | cmdDefault = do ideas <- if null cmdFiles then pure [] else withVerbosity Quiet $ runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing 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 ++ "} # " ++ if null tl then "1 hint" else show (length xs) ++ " hints" | xs@(x : tl) <- bad ] putStr $ unlines $ intercalate ["",""] $ group1:group2:groups 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 >> pure [] | null cmdFiles = exitWithHelp | cmdRefactor = withTempFile $ runHlintMain args cmd . Just | otherwise = runHlintMain args cmd Nothing runHlintMain :: [String] -> Cmd -> Maybe FilePath -> IO [Idea] runHlintMain args cmd tmpFile = do (cmd, settings) <- readAllSettings args cmd runHints args settings =<< resolveFiles cmd tmpFile 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 } readAllSettings :: [String] -> Cmd -> IO (Cmd, [Setting]) readAllSettings args1 cmd@CmdMain{..} = do files <- cmdHintFiles cmd settings1 <- readFilesConfig $ files ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups] let args2 = [x | SettingArgument x <- settings1] 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 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 ["- group:" ," name: " ++ groupName ," enabled: true" ] runHints :: [String] -> [Setting] -> Cmd -> IO [Idea] runHints args settings cmd@CmdMain{..} = withNumCapabilities cmdThreads $ do let outStrLn = whenNormal . putStrLn ideas <- getIdeas cmd settings ideas <- pure $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas if cmdJson then putStrLn $ showIdeasJson ideas else if cmdCC then mapM_ (printIssue . fromIdea) ideas else if cmdSerialise then do hSetBuffering stdout NoBuffering print $ map (show &&& ideaRefactoring) ideas else if cmdRefactor then handleRefactoring ideas cmdFiles cmd else do usecolour <- cmdUseColour cmd let showItem = if usecolour then showIdeaANSI else show mapM_ (outStrLn . showItem) ideas handleReporting ideas cmd pure ideas getIdeas :: Cmd -> [Setting] -> IO [Idea] getIdeas cmd@CmdMain{..} settings = do 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] 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 ideas files cmd@CmdMain{..} = case cmdFiles of [file] -> do -- Ensure that we can find the executable path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor) -- writeFile "hlint.refact" let hints = show $ map (show &&& ideaRefactoring) ideas withTempFile $ \f -> do writeFile f hints 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 let outStrLn = whenNormal . putStrLn forM_ cmdReports $ \x -> do 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] evaluateList :: [a] -> IO [a] evaluateList xs = do evaluate $ length xs pure xs hlint-3.5/src/Hint/0000755000000000000000000000000007346545000012361 5ustar0000000000000000hlint-3.5/src/Hint/All.hs0000644000000000000000000000556607346545000013441 0ustar0000000000000000 module Hint.All( Hint(..), ModuHint, resolveHints, hintRules, builtinHints ) where import Data.Monoid import Config.Type import Data.Either import Data.List.Extra import Hint.Type import Timing import Util import Prelude import Hint.Match import Hint.List import Hint.ListRec import Hint.Monad import Hint.Lambda import Hint.Bracket import Hint.Fixities import Hint.Naming import Hint.Pattern import Hint.Import import Hint.Export import Hint.Pragma import Hint.Restrict import Hint.Extensions import Hint.Duplicate import Hint.Comment 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 | HintFixities | HintBracket | HintNaming | HintPattern | HintImport | HintExport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict | 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 HintLambda -> decl lambdaHint HintImport -> modu importHint HintExport -> modu exportHint HintComment -> modu commentHint HintPragma -> modu pragmaHint 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} 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} -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)] 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 -- | Transform a list of 'HintRule' into a 'Hint'. hintRules :: [HintRule] -> Hint hintRules = resolveHints . map Right hlint-3.5/src/Hint/Bracket.hs0000644000000000000000000002654207346545000014301 0ustar0000000000000000{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {- Raise an error if you are bracketing an atom, or are enclosed by a list bracket. -- expression bracket reduction yes = (f x) x -- @Suggestion f x x no = f (x x) yes = (foo) -- foo yes = (foo bar) -- @Suggestion foo bar yes = foo (bar) -- @Warning bar yes = foo ((x x)) -- @Suggestion (x x) yes = (f x) ||| y -- @Suggestion f x ||| y yes = if (f x) then y else z -- @Suggestion if f x then y else z yes = if x then (f y) else z -- @Suggestion if x then f y else z yes = (a foo) :: Int -- @Suggestion a foo :: Int yes = [(foo bar)] -- @Suggestion [foo bar] yes = foo ((x y), z) -- @Suggestion (x y, z) yes = C { f = (e h) } -- @Suggestion C {f = e h} yes = \ x -> (x && x) -- @Suggestion \x -> x && x no = \(x -> y) -> z yes = (`foo` (bar baz)) -- @Suggestion (`foo` bar baz) yes = f ((x)) -- @Warning x 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)) -- @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) -- type bracket reduction foo :: (Int -> Int) -> Int foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a instance Named (DeclHead S) data Foo = Foo {foo :: (Maybe Foo)} -- @Suggestion foo :: Maybe Foo -- pattern bracket reduction foo (x:xs) = 1 foo (True) = 1 -- @Warning True foo ((True)) = 1 -- @Warning True f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing -- dollar reduction tests no = groupFsts . sortFst $ mr yes = split "to" $ names -- split "to" names yes = white $ keysymbol -- white keysymbol yes = operator foo $ operator -- operator foo operator 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 yes = (a b $ c d) ++ e -- a b (c d) ++ e no = (f . g $ a) ++ e no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool) foo = (case x of y -> z; q -> w) :: Int -- backup fixity resolution main = do a += b . c; return $ a . b -- <$> bracket tests yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q no = foo . bar x <$> baz q -- annotations main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} main = 1; {-# ANN module (1 + (2)) #-} -- 2 -- special case from esqueleto, see #224 main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail) -- unknown fixity, see #426 bad x = x . (x +? x . x) -- special case people don't like to warn on 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) |] -} module Hint.Bracket(bracketHint) where 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 prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) ++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LHsType GhcPs]) ++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LPat GhcPs]) ++ concatMap fieldDecl (childrenBi x) where -- Brackets the roots of annotations are fine, so we strip them. annotations :: AnnDecl GhcPs -> AnnDecl GhcPs annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of L _ (HsPar _ _ x _) -> x x -> x -- 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 -- If we find ourselves in the context of a section and we want to -- issue a warning that a child therein has unneccessary brackets, -- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found : -- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the -- latter (in contrast to the HSE pretty printer). This patches things -- up. prettyExpr :: LHsExpr GhcPs -> String prettyExpr s@(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 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) isPartialAtom :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool -- Might be '$x', which was really '$ x', but TH enabled misparsed it. isPartialAtom _ (L _ (HsSpliceE _ (HsTypedSplice _ DollarSplice _ _) )) = True isPartialAtom _ (L _ (HsSpliceE _ (HsUntypedSplice _ DollarSplice _ _) )) = True -- Might be '$(x)' where the brackets are required in GHC 8.10 and below isPartialAtom (Just (L _ HsSpliceE{})) _ = True isPartialAtom _ x = isRecConstr x || isRecUpdate 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, 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 (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 (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 ppr_names [n] = ppr n ppr_names ns = sep (punctuate comma (map ppr ns)) fieldDecl _ = [] -- 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 $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d , let y = noLocA (HsApp EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed a b c :: LHsExpr GhcPs , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"] splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)] splitInfix (L l (OpApp _ lhs op rhs)) = [(L l . OpApp EpAnnNotUsed lhs op, rhs), (\lhs -> L l (OpApp EpAnnNotUsed lhs op rhs), lhs)] splitInfix _ = [] hlint-3.5/src/Hint/Comment.hs0000644000000000000000000000325407346545000014323 0ustar0000000000000000 {- {- MISSING HASH #-} -- {-# MISSING HASH #-} {- INLINE X -} {- INLINE Y -} -- {-# INLINE Y #-} {- INLINE[~k] f -} -- {-# INLINE[~k] f #-} {- NOINLINE Y -} -- {-# NOINLINE Y #-} {- UNKNOWN Y -} INLINE X -} module Hint.Comment(commentHint) where import Hint.Type import Data.Char import Data.List.Extra import Refact.Types(Refactoring(ModifyComment)) import GHC.Types.SrcLoc import GHC.Parser.Annotation import GHC.Util import qualified GHC.Data.Strict directives :: [String] directives = words $ "LANGUAGE OPTIONS_GHC INCLUDE WARNING DEPRECATED MINIMAL INLINE NOINLINE INLINABLE " ++ "CONLIKE LINE SPECIALIZE SPECIALISE UNPACK NOUNPACK SOURCE" 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 -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 = let s1 = commentText o loc = RealSrcSpan (anchor 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)] hlint-3.5/src/Hint/Duplicate.hs0000644000000000000000000001056007346545000014631 0ustar0000000000000000{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {- Find bindings within a let, and lists of statements If you have n the same, error out 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 {-# 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 ??? -} module Hint.Duplicate(duplicateHint) where 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.List.NonEmpty as NE import qualified Data.Map as Map import GHC.Types.SrcLoc import GHC.Hs import GHC.Utils.Outputable import GHC.Data.Bag 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 = -- 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 = bagToList b ] where ds = [(modName m, fromMaybe "" (declName d), unLoc d) | ModuleEx m <- map snd ms , d <- hsmodDecls (unLoc m)] dupes :: (Outputable e, Data e) => [(String, String, [LocatedA e])] -> [Idea] dupes ys = [(rawIdeaN (if length xs >= 5 then Hint.Type.Warning else Suggestion) "Reduce duplication" p1 (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, SrcSpanD (locA (getLoc x))), extendInstances (stripLocs x)) | x <- xs] --------------------------------------------------------------------- -- DUPLICATE FINDING -- | The position to return if we match at this point, and the map of where to go next -- If two runs have the same vals, always use the first pos you find data Dupe pos val = Dupe pos (Map.Map val (Dupe pos val)) find :: Ord val => [val] -> Dupe pos val -> (pos, Int) find (v:vs) (Dupe p mp) | Just d <- Map.lookup v mp = second (+1) $ find vs d find _ (Dupe p mp) = (p, 0) add :: Ord val => pos -> [val] -> Dupe pos val -> Dupe pos val add pos [] d = d 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 :: forall pos val. (Ord pos, Default pos, Ord val) => Int -> [[(pos,val)]] -> [(pos,pos,[val])] duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs where f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]]) f d xs = second overlaps $ mapAccumL (g pos) d $ 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 = NE.toList $ snd <$> xs (p,i) = find vs d 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 overlaps [] = [] hlint-3.5/src/Hint/Export.hs0000644000000000000000000000340007346545000014173 0ustar0000000000000000{- Suggest using better export declarations main = 1 module Foo where foo = 1 -- module Foo(module Foo) where module Foo(foo) where foo = 1 module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where -} {-# LANGUAGE TypeFamilies #-} module Hint.Export(exportHint) where import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore,Note(..)) import GHC.Hs import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader exportHint :: ModuHint exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) ) | Nothing <- exports = let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents EpAnnNotUsed 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 noExtField (noLocA (IEName (noLocA dots)))) : exports') )} in [ignore "Use explicit module export list" (L s o) (noLoc r) []] where o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing } isMod (L _ (IEModuleContents _ _)) = True isMod _ = False matchesModName m (L _ (IEModuleContents _ (L _ n))) = moduleNameString n == m matchesModName _ _ = False exportHint _ _ = [] hlint-3.5/src/Hint/Extensions.hs0000644000000000000000000005047507346545000015067 0ustar0000000000000000{-# LANGUAGE LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {- Suggest removal of unnecessary extensions i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords {-# LANGUAGE Arrows #-} \ f = id -- {-# LANGUAGE RebindableSyntax #-} \ f = id {-# LANGUAGE RebindableSyntax, ParallelListComp, ImplicitParams #-} \ f = [(a,c) | a <- b | c <- d] -- {-# LANGUAGE RebindableSyntax, ParallelListComp #-} {-# LANGUAGE EmptyDataDecls #-} \ data Foo {-# LANGUAGE TemplateHaskell #-} \ $(deriveNewtypes typeInfo) {-# LANGUAGE TemplateHaskell #-} \ 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 #-} \ $(fmap return $ dataD (return []) (mkName "Void") [] [] []) {-# LANGUAGE RecursiveDo #-} \ main = mdo x <- y; return y {-# LANGUAGE RecursiveDo #-} \ main = do {rec {x <- return 1}; print x} {-# LANGUAGE ImplicitParams, BangPatterns #-} \ sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] \ 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 #-} \ record = 1 -- @Note may require `{-# LANGUAGE DisambiguateRecordFields #-}` adding to the top of the file {-# LANGUAGE RecordWildCards #-} \ {-# LANGUAGE DisambiguateRecordFields #-} \ record = 1 -- @NoNote {-# LANGUAGE UnboxedTuples #-} \ record = 1 -- {-# LANGUAGE TemplateHaskell #-} \ foo {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ record = 1 -- {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ data Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ newtype Foo = Foo Int deriving Class -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ data Foo = Foo Int deriving Class -- {-# LANGUAGE DeriveFunctor #-} \ data Foo = Foo Int deriving Functor {-# LANGUAGE DeriveFunctor #-} \ newtype Foo = Foo Int deriving Functor {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ newtype Foo = Foo Int deriving Functor {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ deriving instance Functor Bar {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ 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 #-} \ class Val a where; val :: a; default val :: Int {-# LANGUAGE TypeApplications #-} \ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int {-# LANGUAGE TypeApplications #-} \ x :: Typeable b => TypeRep @Bool b {-# LANGUAGE LambdaCase #-} \ foo = id -- {-# LANGUAGE LambdaCase #-} \ foo = \case () -> () {-# LANGUAGE NumDecimals #-} \ foo = 12.3e2 {-# LANGUAGE NumDecimals #-} \ foo = id -- {-# LANGUAGE NumDecimals #-} \ foo = 12.345e2 -- {-# LANGUAGE TupleSections #-} \ main = map (,1,2) xs {-# LANGUAGE TupleSections #-} \ main = id -- {-# LANGUAGE OverloadedStrings #-} \ 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 #-} \ data Foo = Foo deriving Bob {-# LANGUAGE DeriveAnyClass #-} \ data Foo a = Foo a deriving (Eq,Data,Functor) -- {-# LANGUAGE MagicHash #-} \ foo# = id {-# LANGUAGE MagicHash #-} \ main = "foo"# {-# LANGUAGE MagicHash #-} \ main = 5# {-# LANGUAGE MagicHash #-} \ main = 'a'# {-# LANGUAGE MagicHash #-} \ main = 5.6# {-# LANGUAGE MagicHash #-} \ foo = id -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ newtype X = X Int deriving newtype Show {-# LANGUAGE EmptyCase #-} \ main = case () of {} {-# LANGUAGE EmptyCase #-} \ main = case () of x -> x -- {-# LANGUAGE EmptyCase #-} \ main = case () of x -> x -- {-# LANGUAGE PolyKinds, KindSignatures #-} -- {-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds, KindSignatures #-} \ 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 -} module Hint.Extensions(extensionsHint) where import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments) import Extension import Data.Generics.Uniplate.DataOnly import Control.Monad.Extra import Data.Maybe import Data.List.Extra import Data.Data import Refact.Types import qualified Data.Set as Set import qualified Data.Map as Map 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 qualified GHC.Data.Strict 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 Hint.Type.Warning "Unused LANGUAGE pragma" (RealSrcSpan (anchor sl) GHC.Data.Strict.Nothing) (comment_ (mkLanguagePragmas sl exts)) (Just newPragma) ( [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) <- languagePragmas $ pragmas (modComments 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) $ mapMaybe snd before) = [] | otherwise = before \\ after , let newPragma = if null after then "" else comment_ (mkLanguagePragmas sl $ map fst after) ] 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. -- All the extensions defined to be used. extensions :: Set.Set Extension extensions = Set.fromList $ mapMaybe readExtension $ concatMap snd $ languagePragmas (pragmas (modComments x)) -- 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"] deriveCategory = ["Functor","Foldable","Traversable"] -- | Classes that can't require newtype deriving noDeriveNewtype = delete "Enum" deriveHaskell ++ -- Enum can't always be derived on a newtype 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 -> Located HsModule -> 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 -> Bool used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep GhcPs) used ImplicitParams = hasT (un :: HsIPName) used TypeApplications = hasS isTypeApp ||^ hasS isKindTyApp used EmptyDataDecls = hasS f where f :: HsDataDefn GhcPs -> Bool f (HsDataDefn _ _ _ _ _ [] _) = True f _ = False used EmptyCase = hasS f where f :: HsExpr GhcPs -> Bool f (HsCase _ _ (MG _ (L _ []) _)) = True f (HsLamCase _ _ (MG _ (L _ []) _)) = True f _ = False used KindSignatures = hasT (un :: HsKind GhcPs) used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch used TemplateHaskell = hasS $ not . isQuasiQuoteSplice 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 :: 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 MultiWayIf = hasS isMultiIf used NumericUnderscores = hasS f where f :: OverLitVal -> Bool f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` t f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` t f _ = False used LambdaCase = hasS isLCase used TupleSections = hasS isTupleSection used OverloadedStrings = hasS isString used OverloadedLists = hasS isListExpr ||^ hasS isListPat where isListExpr :: HsExpr GhcPs -> Bool isListExpr (HsVar _ n) = rdrNameStr n == "[]" isListExpr ExplicitList{} = True isListExpr ArithSeq{} = True isListExpr _ = False isListPat :: Pat GhcPs -> Bool isListPat ListPat{} = True isListPat _ = False used OverloadedLabels = hasS isOverLabel 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 -> 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] ,derivesAnyclass :: [String] ,derivesNewtype' :: [String] } instance Semigroup Derives where Derives x1 x2 x3 <> Derives y1 y2 y3 = Derives (x1 ++ y1) (x2 ++ y2) (x3 ++ y3) instance Monoid Derives where mempty = Derives [] [] [] mappend = (<>) addDerives :: Maybe NewOrData -> Maybe (DerivStrategy GhcPs) -> [String] -> Derives addDerives _ (Just s) xs = case s of StockStrategy {} -> mempty{derivesStock' = xs} AnyclassStrategy {} -> mempty{derivesAnyclass = xs} NewtypeStrategy {} -> mempty{derivesNewtype' = xs} ViaStrategy {} -> mempty addDerives nt _ xs = mempty {derivesStock' = stock ,derivesAnyclass = other ,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []} where (stock, other) = partition (`elem` deriveStock) xs derives :: Located HsModule -> 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_ND=dn, dd_derivs=ds}}) = g dn ds decl :: LHsDecl GhcPs -> Derives decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=ds}))) = g dn ds -- Data declaration. decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration. decl _ = mempty g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | (strategy, tys) <- stys] where stys = [(strategy, [ty]) | L _ (HsDerivingClause _ strategy (L _ (DctSingle _ ty))) <- ds] ++ [(strategy, tys ) | L _ (HsDerivingClause _ strategy (L _ (DctMulti _ tys))) <- ds] 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]) hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi hlint-3.5/src/Hint/Fixities.hs0000644000000000000000000000476707346545000014517 0ustar0000000000000000{- Raise a warning if you have redundant brackets in nested infix expressions. 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 -} 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 HsLamCase{} = True needParenAsChild HsCase{} = True needParenAsChild HsIf{} = True needParenAsChild _ = False hlint-3.5/src/Hint/Import.hs0000644000000000000000000001263307346545000014174 0ustar0000000000000000{-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-} {- Reduce the number of import declarations. Two import declarations can be combined if: (note, A[] is A with whatever import list, or none) import A[]; import A[] = import A[] import A(B); import A(C) = import A(B,C) import A; import A(C) = import A import A; import A hiding (C) = import A import A[]; import A[] as Y = import A[] as Y import A; import A -- import A import A; import A; import A -- import A import A(Foo) ; import A -- import A import A ;import A(Foo) -- import A import A(Bar(..)); import {-# SOURCE #-} A import A; import B import A(B) ; import A(C) -- import A(B,C) import A; import A hiding (C) -- import A import A; import A as Y -- import A as Y import A; import qualified A as Y import A as B; import A as C import A as A -- import A import qualified A as A -- import qualified A import A; import B; import A -- import A import qualified A; import A import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar) import A (foo) \ import A (bar) \ import A (baz) -- import A ( foo, bar, baz ) -} module Hint.Import(importHint) where import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSSA,rawIdea) import Refact.Types hiding (ModuleName) import qualified Refact.Types 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.Unit.Types -- for 'NotBoot' import GHC.Types.PkgQual import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable rawPkgQualToMaybe :: RawPkgQual -> Maybe StringLiteral rawPkgQualToMaybe x = case x of NoRawPkgQual -> Nothing RawPkgQual lit -> Just lit 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 :: [LImportDecl GhcPs] -> Maybe ([LImportDecl GhcPs], [Refactoring R.SrcSpan]) simplify [] = Nothing simplify (x : xs) = case simplifyHead x xs of Nothing -> first (x:) <$> simplify xs Just (xs, rs) -> let deletions = filter (\case Delete{} -> True; _ -> False) rs in Just $ maybe (xs, rs) (second (++ deletions)) $ simplify xs 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) 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) <- ideclHiding x' , Just (False, ys) <- ideclHiding y' = let newImp = L loc x'{ideclHiding = Just (False, 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 (ideclHiding x') || isNothing (ideclHiding y') = let (newImp, toDelete) = if isNothing (ideclHiding 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 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) (ideclHiding x') == transformBi (const noSrcSpan) (ideclHiding y') 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 _ = [] hlint-3.5/src/Hint/Lambda.hs0000644000000000000000000004113107346545000014075 0ustar0000000000000000{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-} {- Concept: Remove all the lambdas you can be inserting only sections Never create a right section with +-# as the operator (they are misparsed) 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 ==> y -- eta reduce ((#) x) ==> (x #) -- rotate operators (flip op x) ==> (`op` x) -- rotate operators \x y -> x + y ==> (+) -- insert operator \x y -> op y x ==> flip op \x -> x + y ==> (+ y) -- insert section, \x -> op x y ==> (`op` y) -- insert section \x -> y + x ==> (y +) -- insert section \x -> \y -> ... ==> \x y -- lambda compression \x -> (x +) ==> (+) -- operator reduction 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 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) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(foo -> x) -> \y -> x x y y) f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i) f = bar (flip Foo.bar x) -- (`Foo.bar` x) f = 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 f = \z -> foo $ z $ baz z where f = \x -> bar map (filter x) where -- bar map . filter f = bar &+& \x -> f (g x) foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m] foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) foo a b c = bar (flux ++ quux) c where flux = 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) 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"] -} module Hint.Lambda(lambdaHint) where import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan) import Util import Data.List.Extra import Data.Set (Set) import qualified Data.Set 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.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 (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 _) 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] | 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 noExtField (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField]) Generated} 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) 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 EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed 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 ++ ")") lambdaExp p o@(L _ HsLam{}) | 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 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 (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 EpAnnNotUsed (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) (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) (m_pats oldmatch) in [ suggest "Use lambda" (reLoc o) ( noLoc $ HsLam noExtField oldMG { mg_alts = noLocA [ noLocA oldmatch { m_pats = map mkParPat $ m_pats oldmatch , m_ctxt = LambdaExpr } ] } :: Located (HsExpr GhcPs) ) r ] -- otherwise we should use @LambdaCase@ MG _ (L _ _) _ -> [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed 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 EpAnnNotUsed 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" -- | 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)) isWildPat :: LPat GhcPs -> Bool isWildPat = \case (L _ (WildPat _)) -> True; _ -> False -- 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)) hlint-3.5/src/Hint/List.hs0000644000000000000000000002655607346545000013646 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-} {- Find and match: yes = 1:2:[] -- [1,2] yes = ['h','e','l','l','o'] yes (1:2:[]) = 1 -- [1,2] yes ['h','e'] = 1 -- [a]++b -> a : b, but only if not in a chain of ++'s yes = [x] ++ xs -- x : xs no = "x" ++ xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys yes = [if a then b else c] ++ xs -- (if a then b else c) : xs yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]] yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs data Yes = Yes (Maybe [Char]) -- Maybe String yes = y :: [Char] -> a -- String -> a instance C [Char] foo = [a b] ++ xs -- a b : xs foo = [myexpr | True, a] -- [myexpr | a] foo = [myexpr | False] -- [] foo = map f [x + 1 | x <- [1..10]] -- [f (x + 1) | x <- [1..10]] foo = [x + 1 | x <- [1..10], feature] -- [x + 1 | feature, x <- [1..10]] foo = [x + 1 | x <- [1..10], even x] foo = [x + 1 | x <- [1..10], even x, dont_reoder_guards] foo = [x + 1 | x <- [1..10], let y = even x, y] 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:[] -} module Hint.List(listHint) where import Control.Applicative import Data.Generics.Uniplate.DataOnly import Data.List.Extra import Data.Maybe import Prelude import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Basic hiding (Pattern) 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 _ modu = listDecl overloadedListsOn where exts = concatMap snd (languagePragmas (pragmas (modComments modu))) overloadedListsOn = "OverloadedLists" `elem` exts listDecl :: Bool -> LHsDecl GhcPs -> [Idea] listDecl overloadedListsOn x = concatMap (listExp overloadedListsOn False) (childrenBi x) ++ stringType x ++ concatMap listPat (childrenBi x) ++ concatMap listComp (universeBi x) -- 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 = reverse stmts e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last. xs = reverse (tail revs) in list_comp_aux e xs where list_comp_aux e xs | "False" `elem` cons = [suggest "Short-circuited list comprehension" (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' = noLocA $ ExplicitList EpAnnNotUsed [] o2 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e])) o3 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ ys ++ [e]) cons = mapMaybe qualCon xs qualCon :: ExprLStmt GhcPs -> Maybe String qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x) qualCon _ = Nothing 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 revs = reverse stmts L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last. last = noLocA $ LastStmt noExtField (noLocA $ HsApp EpAnnNotUsed (paren f) (paren body)) b s o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ reverse (tail revs) ++ [last]) listCompCheckMap _ _ _ _ _ = [] suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan] suggestExpr o o2 = [Replace Expr (toSSA o) [] (unsafePrettyPrint o2)] moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs] moveGuardsForward = reverse . f [] . reverse where f guards (x@(L _ (BindStmt _ p _)) : xs) = reverse stop ++ x : f move xs where (move, stop) = span (if any hasPFieldsDotDot (universeBi x) || any isPFieldWildcard (universeBi x) then const False else \x -> 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 listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea] listExp overloadedListsOn b (fromParen -> x) = if null res then concatMap (listExp overloadedListsOn $ isAppend x) $ children x else [head 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 [head res] where res = [suggest name (reLoc x) (reLoc x2) [r] | (name, f) <- pchecks , Just (x2, subts, temp) <- [f x] , let r = Replace Pattern (toSSA x) subts temp ] isAppend :: View a App2 => a -> Bool isAppend (view -> App2 op _ _) = varToStr op == "++" isAppend _ = False 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 :: [(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 :: 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) -> (noLocA (ListPat EpAnnNotUsed e) , map (fmap toRefactSrcSpan . fst) s , unsafePrettyPrint (noLocA $ ListPat EpAnnNotUsed (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 :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs) g s (locA . getLoc -> loc) = ((s, loc), noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit s))) 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 EpAnnNotUsed (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) -> (noLocA (ExplicitList EpAnnNotUsed e) , map (fmap toSSA) s , unsafePrettyPrint (noLocA $ ExplicitList EpAnnNotUsed (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 g :: String -> LHsExpr GhcPs -> (String, LHsExpr GhcPs) g s p = (s, L (getLoc p) (unLoc $ strToVar s)) 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 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 :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs gen x = noLocA . OpApp EpAnnNotUsed x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar = noLocA $ HsListTy EpAnnNotUsed (noLocA (HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString = noLocA $ HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) 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 everthing but the instance type. _ -> f x where f x = concatMap g $ childrenBi x 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] hlint-3.5/src/Hint/ListRec.hs0000644000000000000000000002125207346545000014264 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {- map f [] = [] map f (x:xs) = f x : map f xs foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs -} {- f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs f (x:xs) a = a + x >>= \fax -> f xs fax ; f [] a = pure a -- f xs a = foldM (+) a xs foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr foo x ys 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 -} module Hint.ListRec(listRecHint) where 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 f o = maybeToList $ do let x = o (x, addCase) <- findCase x (use,severity,x) <- matchListRec x let y = addCase x guard $ recursiveStr `notElem` varss y -- Maybe we can do better here maintaining source -- formatting? pure $ idea severity ("Use " ++ use) (reLoc o) (reLoc y) [Replace Decl (toSSA o) [] (unsafePrettyPrint y)] recursiveStr :: String recursiveStr = "_recursive_" 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) 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, 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 , 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 [ 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 _ MG { mg_origin=FromSource , mg_alts=L _ [ L _ Match { m_ctxt=LambdaExpr , m_pats=[v@(L _ VarPat{})] , m_grhss=GRHSs _ [L _ (GRHS _ [] rhs)] (EmptyLocalBinds _)}]})) ) = [ noLocA $ BindStmt EpAnnNotUsed v lhs , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs) findCase x = do -- Match a function binding with two alternatives. (L _ (ValD _ FunBind {fun_matches= MG{mg_origin=FromSource, mg_alts= (L _ [ x1@(L _ Match{..}) -- Match fields. , x2]), ..} -- Match group fields. , ..} -- Fun. bind fields. )) <- pure x Branch name1 ps1 p1 c1 b1 <- findBranch x1 Branch name2 ps2 p2 c2 b2 <- findBranch x2 guard (name1 == name2 && ps1 == ps2 && p1 == p2) [(BNil, b1), (BCons x xs, b2)] <- 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 EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs. gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set. match e = Match{m_ext=EpAnnNotUsed,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match. matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_origin=Generated, ..} -- Match group. funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind. 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] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons) where args = [zs | z : zs <- map fromApps $ universeApps cons, astEq z recursive] elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i, p) <- zipFrom 0 ps] ++ repeat False remove = concat . zipWith (\b x -> [x | not b]) elim f (fromApps -> x : xs) | astEq x recursive = apps $ x : remove xs f x = x --------------------------------------------------------------------- -- FIND A BRANCH 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 ps pure $ Branch (occNameStr name) a b c $ simplifyExp body findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList) findPat ps = do ps <- mapM readPat ps [i] <- pure $ findIndices isRight ps let (left, [right]) = partitionEithers ps pure (left, i, right) readPat :: LPat GhcPs -> Maybe (Either String BList) readPat (view -> PVar_ x) = Just $ Left x 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 hlint-3.5/src/Hint/Match.hs0000644000000000000000000002732507346545000013762 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-} {- The matching does a fairly simple unification between the two terms, treating any single letter variable on the left as a free variable. After the matching we substitute, transform and check the side conditions. We also "see through" both ($) and (.) functions on the right. TRANSFORM PATTERNS _noParen_ - don't bracket this particular item SIDE CONDITIONS (&&), (||), not - boolean connectives isAtom x - does x never need brackets isFoo x - is the root constructor of x a "Foo" notEq x y - are x and y not equal notIn xs ys - are all x variables not in ys expressions noTypeCheck, noQuickCheck - no semantics, a hint for testing only ($) AND (.) We see through ($)/(.) by expanding it if nothing else matches. We also see through (.) by translating rules that have (.) equivalents to separate rules. For example: concat (map f x) ==> concatMap f x -- we spot both these rules can eta reduce with respect to x concat . map f ==> concatMap f -- we use the associativity of (.) to add concat . map f . x ==> concatMap f . x -- currently 36 of 169 rules have (.) equivalents We see through (.) if the RHS is dull using id, e.g. not (not x) ==> x not . not ==> id not . not . x ==> x -} module Hint.Match(readMatch) where import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSSA) import Util import Timing import qualified Data.Set as Set import qualified Refact.Types as R import Control.Monad import Data.Tuple.Extra import Data.Maybe import Config.Type import Data.Generics.Uniplate.DataOnly import GHC.Data.Bag 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] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch settings = findIdeas (concatMap readRule settings) readRule :: HintRule -> [HintRule] 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 :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)] dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)] 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 EpAnnNotUsed x op)) -- (a == ) rSec = addParen (L l (SectionR EpAnnNotUsed op y)) -- ( == b) in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion _ = [] --------------------------------------------------------------------- -- PERFORM THE MATCHING findIdeas :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList [ (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) ] -- | 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 <- bagToList 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 -> 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) (u, extra) <- unifyExp nm True lhs x u <- validSubst astEq u -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res'). let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp EpAnnNotUsed 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 (LHsExpr GhcPs) -> [(String, LHsExpr GhcPs)] -> Bool checkSide x bind = maybe True bool x where 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 (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 :: 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 isFieldPun (universeBi 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 isType typ (L _ x) = let top = showConstr (toConstr x) in typ == top 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 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 :: 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 '_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 -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify from to = transformBi f where f :: LocatedN RdrName -> LocatedN RdrName f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x f x = scopeMove (from, x) to 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 EpAnnNotUsed x))) f x = x hlint-3.5/src/Hint/Monad.hs0000644000000000000000000003451607346545000013764 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {- Find and match: mapM, foldM, forM, replicateM, sequence, zipWithM not at the last line of a do statement, or to the left of >> Use let x = y instead of x <- return y, unless x is contained within y, or bound more than once in that do block. yes = do mapM print a; return b -- mapM_ print a yes = do _ <- mapM print a; return b -- mapM_ print a no = mapM print a no = do foo ; mapM print a 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 yes = do x <- bar; x -- do join bar no = do x <- bar; x; x yes = do x <- bar; return (f x) -- do f <$> bar yes = do x <- bar; return $ f x -- do f <$> bar yes = do x <- bar; pure $ f x -- do f <$> bar yes = do x <- bar; return $ f (g x) -- do f . g <$> bar yes = do x <- bar; return (f $ g x) -- do f . g <$> bar 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 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 () yes = do if a then forM x y else return (); return 12 -- forM_ x y yes = do case a of {_ -> forM x y; x:xs -> foo xs}; return () -- forM_ x y foldM_ f a xs = foldM f a xs >> return () folder f a xs = foldM f a xs >> return () -- foldM_ f a xs 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 {-# 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) -- 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 () -} module Hint.Monad(monadHint) where 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.Bag import qualified GHC.Data.Strict 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 Refact.Types hiding (Match) import qualified Refact.Types 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 (f Nothing Nothing) $ childrenBi d where 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 -- | 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 EpAnnNotUsed op) x (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp EpAnnNotUsed 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 EpAnnNotUsed (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 p y q)) = seenVoid (wrap . L l . \y -> HsPar x p y q) 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 -- Sometimes people write do, to avoid identation, see -- https://github.com/ndmitchell/hlint/issues/978 -- Return True if they are using do as avoiding identation doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L anna _)))) (L _ (HsDo _ _ (L annb _))) | SrcSpanAnn _ (RealSrcSpan a _) <- anna , SrcSpanAnn _ (RealSrcSpan b _) <- annb = srcSpanStartCol a == srcSpanStartCol b doAsAvoidingIndentation parent self = False -- 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 _ p x q )) = go (wrap . L l . \x -> HsPar EpAnnNotUsed p x q) x go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp EpAnnNotUsed x y)) x go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp EpAnnNotUsed 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 EpAnnNotUsed 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 EpAnnNotUsed x tag y)) x | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp EpAnnNotUsed x tag) y monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_" = [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 :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea] -- 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)]] -- 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)]] -- 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 EpAnnNotUsed (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)] -- Redundant variable capture. Rewrite 'do _ <- ; $1' as -- 'do ; $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"]] -- Redundant unit return : 'do ; 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)]] -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap 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 EpAnnNotUsed (foldl' (\acc e -> noLocA $ OpApp EpAnnNotUsed 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 :: ([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] 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 EpAnnNotUsed [] rhs) grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField) match = noLocA $ Match EpAnnNotUsed (FunRhs p Prefix NoSrcStrict) [] grhss fb = noLocA $ FunBind noExtField p (MG noExtField (noLocA [match]) Generated) [] binds = unitBag fb valBinds = ValBinds NoAnnSortKey binds [] localBinds = HsValBinds EpAnnNotUsed valBinds in noLocA $ LetStmt EpAnnNotUsed localBinds 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) 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 EpAnnNotUsed x z) fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing hlint-3.5/src/Hint/Naming.hs0000644000000000000000000001171307346545000014131 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {- Suggest the use of camelCase Only permit: _*[A-Za-z]*_*#*'* Apply this to things that would get exported by default only Also allow prop_ as it's a standard QuickCheck idiom Also allow case_ as it's a standard test-framework-th idiom 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 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 data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB case_foo = 1 test_foo = 1 cast_foo = 1 -- castFoo = ... replicateM_ = 1 _foo__ = 1 section_1_1 = 1 runMutator# = 1 foreign import ccall hexml_node_child :: IO () -} module Hint.Naming(namingHint) where import Hint.Type (Idea,DeclHint,suggest,ghcModule) import Data.Generics.Uniplate.DataOnly import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data import Data.Char import Data.Maybe import qualified Data.Set 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 $ hsmodDecls $ unLoc (ghcModule modu) 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 _ (L locMatches matches) FromSource) _))) = L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) = L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) shortenMatch (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 :: HsExpr GhcPs dots = HsLit EpAnnNotUsed (HsString (SourceText "...") (mkFastString "...")) getNames :: LHsDecl GhcPs -> [String] getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) getConstructorNames :: HsDecl GhcPs -> [String] getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) = concatMap (map unsafePrettyPrint . getConNames' . unLoc) cons where getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names getConNames' XConDecl{} = [] getConstructorNames _ = [] isSym :: String -> Bool isSym (x:_) = not $ isAlpha x || x `elem` "_'" isSym _ = False suggestName :: String -> Maybe String suggestName original | isSym original || good || not (any isLower original) || any isDigit original || any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_","tasty_"] = Nothing | otherwise = Just $ f original where good = all isAlphaNum $ drp '_' $ drp '#' $ reverse $ filter (/= '\'') $ drp '_' original drp x = dropWhile (== x) f xs = us ++ g ys where (us,ys) = span (== '_') xs g x | x `elem` ["_","'","_'"] = x g (a:x:xs) | a `elem` "_'" && isAlphaNum x = toUpper x : g xs g (x:xs) | isAlphaNum x = x : g xs | otherwise = g xs g [] = [] 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 hlint-3.5/src/Hint/NewType.hs0000644000000000000000000001770507346545000014322 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {- Suggest newtype instead of data for type declarations that have only one field. Don't suggest newtype for existentially quantified data types because it is not valid. data Foo = Foo Int -- newtype Foo = Foo Int data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show data Foo a b = Foo a -- newtype Foo a b = Foo a data Foo = Foo { 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 { 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 -} module Hint.NewType (newtypeHint) where 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 :: 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 _ = [] -- | 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 _ NewType _ _ _ _ xs) = all hasStrategyClause xs hasAllStrategies _ = False isData :: HsDataDefn GhcPs -> Bool isData (HsDataDefn _ NewType _ _ _ _ _) = False isData (HsDataDefn _ DataType _ _ _ _ _) = 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 = Just WarnNewtype { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef { dd_ND = NewType , dd_cons = dropBangs dataDef }} , insideType = inType } singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl famEqn@(FamEqn _ _ _ _ _ dataDef))))) | Just inType <- simpleHsDataDefn dataDef = Just WarnNewtype { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ famEqn {feqn_rhs = dataDef { dd_ND = NewType , dd_cons = dropBangs dataDef }} , insideType = inType } singleSimpleField _ = Nothing dropBangs :: HsDataDefn GhcPs -> [LConDecl GhcPs] dropBangs = map (fmap dropConsBang) . dd_cons -- | Checks whether its argument is a \"simple\" data definition (see 'singleSimpleField') -- returning the type inside its constructor if it is. simpleHsDataDefn :: HsDataDefn GhcPs -> Maybe (HsType GhcPs) simpleHsDataDefn (HsDataDefn _ DataType _ _ _ [L _ constructor] _) = simpleCons constructor simpleHsDataDefn _ = Nothing -- | 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 isHashy :: HsType GhcPs -> Bool isHashy x = or ["#" `isSuffixOf` unsafePrettyPrint v | v@HsTyVar{} <- universe x] warnBang :: HsType GhcPs -> Bool warnBang (HsBangTy _ (HsSrcBang _ _ 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 hlint-3.5/src/Hint/NumLiteral.hs0000644000000000000000000001034507346545000014774 0ustar0000000000000000{- Suggest the usage of underscore when NumericUnderscores is enabled. 123456 {-# 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 -} module Hint.NumLiteral (numLiteralHint) where import GHC.Hs 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.Generics.Uniplate.DataOnly (universeBi) import Refact.Types import Hint.Type (DeclHint, toSSA, modComments) import Idea (Idea, suggest) numLiteralHint :: DeclHint numLiteralHint _ modu = if NumericUnderscores `elem` extensions (modComments modu) 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` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText 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` srcTxt, srcTxt /= underscoredSrcTxt ] where underscoredSrcTxt = addUnderscore srcTxt y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText 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 = reverse . underscore chunkSize . reverse 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 hlint-3.5/src/Hint/Pattern.hs0000644000000000000000000002605307346545000014340 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-} {- Improve the structure of code yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e no x y = if a then b else c -- foo b | c <- f b = c -- foo (f -> c) = c -- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c foo b | c <- f b = c + b foo b | c <- f b = c where f = here foo b | c <- f b = c where foo = b foo b | c <- f b = c \ | 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 | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x foo (Bar _ _) = x foo = case f v of _ -> x -- x 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 {-# 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 {-# 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 {-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y) {-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x] foo !Bar { bar = x } = x -- Bar { bar = x } {-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ()) foo x@_ = x -- x foo x@Foo = x otherwise = True -} module Hint.Pattern(patternHint) where import Hint.Type(DeclHint,Idea,modComments,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), SrcSpan) import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence import GHC.Data.Bag import GHC.Types.Basic hiding (Pattern) import qualified GHC.Data.Strict 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 _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) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++ concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu))) -- language extensions enabled at source strict = "Strict" `elem` exts 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 hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind) | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats , p `notElem` (vars bod ++ vars bind) , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats = [gen "Use view patterns" $ Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind] where decsBind = nub $ concatMap declBind $ childrenBi bind -} 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 mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)) mkGuard a = GRHS EpAnnNotUsed [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLocA . uncurry mkGuard) rawGuards (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) 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 template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs emptyComments templateGuards 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 EpAnnNotUsed [] 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 _ bag _)) = isEmptyBag bag 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 EpAnnNotUsed [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)] data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) -- Invariant: Number of patterns may not change asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] asPattern (L loc x) = concatMap decl (universeBi x) where decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] decl o@(PatBind _ pat rhs _) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind EpAnnNotUsed pat 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 pats grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match EpAnnNotUsed ctx pats grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs) -- 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 [] Nothing :: HsRecFields GhcPs (LPat GhcPs) new = noLocA $ ConPat EpAnnNotUsed 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 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 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 _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]) FromSource ))) = [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 _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]) FromSource ))) | occNameStr x == occNameStr y = [suggest "Redundant case" (reLoc o) (reLoc e) [r]] where r = Replace Expr (toSSA o) [("x", toSSA e)] "x" expHint _ = [] hlint-3.5/src/Hint/Pragma.hs0000644000000000000000000001420607346545000014127 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {- Suggest better pragmas OPTIONS_GHC -cpp => LANGUAGE CPP OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE) OPTIONS_GHC -XFoo => LANGUAGE Foo LANGUAGE A, A => LANGUAGE A -- do not do LANGUAGE A, LANGUAGE B to combine {-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-} {-# 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 #-} @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 EmptyCase, RebindableSyntax #-} -} module Hint.Pragma(pragmaHint) where import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments) import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe import Refact.Types import qualified Refact.Types as R import GHC.Hs import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Util import GHC.Driver.Session pragmaHint :: ModuHint pragmaHint _ modu = let ps = pragmas (modComments modu) opts = flags ps lang = languagePragmas ps in languageDupes lang ++ optToPragma opts lang 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 <- flags, Just (new, ns) <- [optToLanguage old ls] , let r = mkRefact old new ns] ls = concatMap snd languagePragmas ns2 = nubOrd (concat ns) \\ ls dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1 dummySpan = mkRealSrcSpan dummyLoc dummyLoc dummyAnchor = realSpanAsAnchor dummySpan 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 (getAncLoc old) (comment_ old) (Just $ comment_ new) [] [ModifyComment (toSSAnc old) (comment_ new)] MultiComment repl delete new -> mkFewer (getAncLoc repl) (f [repl, delete]) (Just $ comment_ new) [] [ ModifyComment (toSSAnc repl) (comment_ new) , ModifyComment (toSSAnc delete) ""] OptionsToComment old new r -> mkLanguage (getAncLoc . NE.head $ old) (f $ NE.toList old) (Just $ f new) [] r where f = unlines . map comment_ mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas" mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas" 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? strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags strToLanguage _ = Nothing -- 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 = filter (not . (`elem` languagePragmas)) (concat $ catMaybes vs) in Just (res, ls) where -- Try reinterpreting each flag as a list of language features -- (e.g. via '-X'..., '-fglasgow-exts'). vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]' -- Keep any flag that does not enable language extensions. keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags -- If there are flags to keep, 'res' is a new pragma setting just those flags. res = if null keep then Nothing else Just (mkFlags loc keep) optToLanguage _ _ = Nothing hlint-3.5/src/Hint/Restrict.hs0000644000000000000000000003003507346545000014515 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Hint.Restrict(restrictHint) where {- -- These tests rely on the .hlint.yaml file in the root foo = unsafePerformIO -- foo = bar `unsafePerformIO` baz -- module Util where otherFunc = 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 -} import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea,modComments) import Config.Type import Util import Data.Generics.Uniplate.DataOnly import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Map as Map import Data.List.Extra import Data.List.NonEmpty (nonEmpty) 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.Unit.Module 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 = let anns = modComments m ps = pragmas anns 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 = 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 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) -- 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 { riAs = restrictAs , riAsRequired = restrictAsRequired , riImportStyle = restrictImportStyle , riQualifiedStyle = restrictQualifiedStyle , riWithin = restrictWithin , riRestrictIdents = restrictIdents , riMessage = restrictMessage } | Restrict{..} <- rs, s <- restrictName]) ideaMessage :: Maybe String -> Idea -> Idea ideaMessage (Just message) w = w{ideaNote=[Note message]} ideaMessage Nothing w = w{ideaNote=[noteMayBreak]} ideaNoTo :: Idea -> Idea ideaNoTo w = w{ideaTo=Nothing} noteMayBreak :: Note noteMayBreak = Note "may break the code" within :: String -> String -> [(String, String)] -> Bool within modu func = any (\(a,b) -> (a ~= modu || a == "") && (b ~= func || b == "")) where (~=) = wildcardMatch --------------------------------------------------------------------- -- CHECKS 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 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 ideclHiding 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) [] 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 -> (second (<> " or unqualified") <$> expectedQualStyle, Nothing) ImportStyleQualified -> (expectedQualStyleDef, Nothing) ImportStyleExplicitOrQualified | Just (False, _) <- ideclHiding -> (Nothing, Nothing) | otherwise -> ( second (<> " or with an explicit import list") <$> expectedQualStyleDef , Nothing ) ImportStyleExplicit | Just (False, _) <- ideclHiding -> (Nothing, Nothing) | otherwise -> ( Just (NotQualified, "unqualified") , Just $ Just (False, noLocA []) ) ImportStyleUnqualified -> (Just (NotQualified, "unqualified"), Nothing) expectedQualStyleDef = expectedQualStyle <|> Just (QualifiedPre, "qualified") expectedQualStyle = case fromMaybe QualifiedStyleUnrestricted $ getAlt riQualifiedStyle of QualifiedStyleUnrestricted -> Nothing QualifiedStylePost -> Just (QualifiedPost, "post-qualified") QualifiedStylePre -> Just (QualifiedPre, "pre-qualified") qualIdea | Just ideclQualified == (fst <$> expectedQual) = Nothing | otherwise = expectedQual whenJust qualIdea $ \(qual, hint) -> do let i' = noLoc $ (unLoc i){ ideclQualified = qual , ideclHiding = fromMaybe ideclHiding expectedHiding } msg = moduleNameString (unLoc ideclName) <> " should be imported " <> hint Left $ warn msg (reLoc i) i' [] 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 (IdP 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" (reLocN x) (reLocN x) []){ideaDecl = [dname]} | d <- decls , 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) hlint-3.5/src/Hint/Smell.hs0000644000000000000000000001211207346545000013766 0ustar0000000000000000 module Hint.Smell (smellModuleHint,smellHint) where {- [{smell: { type: many arg functions, limit: 2 }}] f :: Int -> Int \ f = undefined f :: Int -> Int -> Int \ f = undefined -- f :: Int -> Int \ f = undefined f :: Int -> Int -> Int \ f = undefined [{smell: { type: long functions, limit: 3}}] f = do \ x <- y \ return x -- f = do \ return z \ \ where \ z = do \ a \ b -- f = do \ return z \ \ where \ z = a f = Con \ { a = x \ , b = y \ , c = z \ } f = return x f = do \ x <- y \ return x f = return x [{smell: { type: long type lists, limit: 2}}] f :: Bool -> Int -> (Int -> Proxy '[a, b]) -- f :: Proxy '[a] f :: Proxy '[a, b] f :: Proxy '[a] [{smell: { type: many imports, limit: 2}}] import A; import B -- import A import A; import B import A -} 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 GHC.Utils.Outputable import GHC.Types.Basic import GHC.Hs import GHC.Data.Bag import GHC.Types.SrcLoc import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable smellModuleHint :: [Setting] -> ModuHint 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 = sniff smellLongFunctions SmellLongFunctions ++ sniff smellLongTypeLists SmellLongTypeLists ++ sniff smellManyArgFunctions SmellManyArgFunctions where sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings) smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea] smellLongFunctions d n = [ idea | (span, idea) <- declSpans d , spanLength span >= n ] -- 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? -- 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_origin=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 _ = [] -- The span of a guarded right hand side. rhsSpans :: HsMatchContext GhcPs -> 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 [] [])] -- 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))) (bagToList bs) whereSpans _ = [] 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 (HsExplicitListTy _ IsPromoted x) = length x >= n longTypeList _ = False smellLongTypeLists _ _ = [] 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 t = countFunctionArgs t >= n smellManyArgFunctions _ _ = [] 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 smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings] hlint-3.5/src/Hint/Type.hs0000644000000000000000000000257407346545000013646 0ustar0000000000000000 module Hint.Type( DeclHint, ModuHint, CrossHint, Hint(..), module Export ) where import Data.Semigroup import Config.Type 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 -> 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 = 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. } instance Semigroup Hint where 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) instance Monoid Hint where mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) mappend = (<>) hlint-3.5/src/Hint/Unsafe.hs0000644000000000000000000000711407346545000014141 0ustar0000000000000000 {- Find things that are unsafe {-# 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 -} module Hint.Unsafe(unsafeHint) where 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 _ (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_origin=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d] -- 'x' is a synonym for an appliciation involing 'unsafePerformIO' , isUnsafeDecl d -- 'x' is not marked 'NOINLINE'. , x `notElem` noinline] where gen :: OccName -> LHsDecl GhcPs gen x = noLocA $ SigD noExtField (InlineSig EpAnnNotUsed (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_origin=FromSource,mg_alts=L _ alts}}) = any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False -- 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 :: HsExpr GhcPs -> Bool isUnsafeFun (HsVar _ (L _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True isUnsafeFun (OpApp _ (L _ l) op _) | isDot op = isUnsafeFun l isUnsafeFun _ = False hlint-3.5/src/HsColour.hs0000644000000000000000000000101607346545000013547 0ustar0000000000000000{-# LANGUAGE CPP #-} module HsColour(hsColourHTML, hsColourConsole) where #ifdef GPL_SCARES_ME hsColourConsole :: String -> String hsColourConsole = id hsColourHTML :: String -> String hsColourHTML = id #else import Prelude import Language.Haskell.HsColour.TTY as TTY import Language.Haskell.HsColour.Colourise import Language.Haskell.HsColour.CSS as CSS hsColourConsole :: String -> String hsColourConsole = TTY.hscolour defaultColourPrefs hsColourHTML :: String -> String hsColourHTML = CSS.hscolour False 1 #endif hlint-3.5/src/Idea.hs0000644000000000000000000001227207346545000012661 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} module Idea( Idea(..), rawIdea, idea, suggest, suggestRemove, ideaRemove, warn, ignore, rawIdeaN, suggestN, ignoreNoSuggestion, showIdeasJson, showIdeaANSI, Note(..), showNotes, Severity(..), ) where import Data.List.Extra import Config.Type import HsColour import Refact.Types hiding (SrcSpan) import qualified Refact.Types 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 {ideaModule :: [String] -- ^ The modules the idea is for, usually a singleton. ,ideaDecl :: [String] -- ^ The declarations the idea is for, usually a singleton, typically the function name, but may be a type name. ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'. ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@. ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to. ,ideaFrom :: String -- ^ The contents of the source code the idea relates to. ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors). ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement. ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea } 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) -- 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 [("module", list $ map str ideaModule) ,("decl", list $ map str ideaDecl) ,("severity", str $ show ideaSeverity) ,("hint", str ideaHint) ,("file", str srcSpanFilename) ,("startLine", show srcSpanStartLine') ,("startColumn", show srcSpanStartColumn) ,("endLine", show srcSpanEndLine') ,("endColumn", show srcSpanEndColumn) ,("from", str ideaFrom) ,("to", maybe "null" str ideaTo) ,("note", list (map (str . show) ideaNote)) ,("refactorings", str $ show ideaRefactoring) ] where str x = "\"" ++ escapeJSON x ++ "\"" 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) ++ "]" instance Show Idea where show = showEx id -- | 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 $ [showSrcSpan ideaSpan ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++ f "Found" (Just ideaFrom) ++ f "Perhaps" ideaTo ++ ["Note: " ++ n | let n = showNotes ideaNote, n /= ""] where f msg Nothing = [] f msg (Just x) | null xs = [msg ++ " you should remove it."] | otherwise = (msg ++ ":") : map (" "++) xs 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 :: (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 hlint-3.5/src/Language/Haskell/0000755000000000000000000000000007346545000014565 5ustar0000000000000000hlint-3.5/src/Language/Haskell/HLint.hs0000644000000000000000000001421707346545000016144 0ustar0000000000000000{-# LANGUAGE PatternGuards, RecordWildCards #-} -- | 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 Config.Type import Config.Read import Idea import qualified Apply as H import HLint import Fixity import GHC.Data.FastString ( unpackFS ) import GHC.All import Hint.All hiding (resolveHints) import qualified Hint.All 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 qualified Hint.Restrict as Restrict -- | 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 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) -- | 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) -- | 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)] -- | 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, he 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 hlint-3.5/src/Main.hs0000644000000000000000000000037007346545000012677 0ustar0000000000000000 module Main(main) where import Language.Haskell.HLint import Control.Monad import System.Environment import System.Exit main :: IO () main = do args <- getArgs errs <- hlint args unless (null errs) $ exitWith $ ExitFailure 1 hlint-3.5/src/Parallel.hs0000644000000000000000000000230407346545000013546 0ustar0000000000000000{- The parallel function (specialised to lists) is equivalent to: import Control.Parallel.Strategies parallel :: [IO [a]] -> IO [[a]] parallel = pure . withStrategy (parList $ seqList r0) . map unsafePerformIO However, this version performs about 10% slower with 2 processors in GHC 6.12.1 -} module Parallel(parallel) where import System.IO.Unsafe import Control.Concurrent import Control.Exception import Control.Monad parallel :: Int -> [IO a] -> IO [a] parallel j = if j <= 1 then parallel1 else parallelN j parallel1 :: [IO a] -> IO [a] parallel1 [] = pure [] parallel1 (x:xs) = do x2 <- x xs2 <- unsafeInterleaveIO $ parallel1 xs pure $ x2:xs2 parallelN :: Int -> [IO a] -> IO [a] parallelN j xs = do ms <- mapM (const newEmptyMVar) xs chan <- newChan mapM_ (writeChan chan . Just) $ zip ms xs replicateM_ j (writeChan chan Nothing >> forkIO (f chan)) let throwE x = throw (x :: SomeException) parallel1 $ map (fmap (either throwE id) . takeMVar) ms where f chan = do v <- readChan chan case v of Nothing -> pure () Just (m,x) -> do putMVar m =<< try x f chan hlint-3.5/src/Refact.hs0000644000000000000000000000634007346545000013222 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} module Refact ( substVars , toRefactSrcSpan , toSS, toSSA, toSSAnc , checkRefactor, refactorPath, runRefactoring ) where import Control.Exception.Extra import Control.Monad 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 qualified Refact.Types as R import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Parser.Annotation 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.SrcSpanAnn' a) e -> R.SrcSpan toSSA = toRefactSrcSpan . GHC.getLocA toSSAnc :: GHC.GenLocated GHC.Anchor 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 . tail <$> 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" , "" ] 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] hlint-3.5/src/Report.hs0000644000000000000000000000550307346545000013271 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Report(writeReport) where import Idea import Data.Tuple.Extra import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Version import Timing import Paths_hlint import HsColour import EmbedData import qualified GHC.Util as GHC writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO () writeTemplate dataDir content to = writeFile to $ unlines $ concatMap f $ lines reportTemplate where f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content f x = [x] writeReport :: FilePath -> FilePath -> [Idea] -> IO () writeReport dataDir file ideas = timedIO "Report" file $ writeTemplate dataDir inner file where generateIds :: [String] -> [(String,Int)] -- sorted by name 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 inner = if null ideas then emptyInner else nonEmptyInner emptyInner = [("VERSION",['v' : showVersion version]),("CONTENT", ["No hints"]), ("HINTS", ["
  • No hints
  • "]),("FILES", ["
  • No files
  • "])] nonEmptyInner = [("VERSION",['v' : showVersion version]),("CONTENT",content), ("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 (GHC.srcSpanFilename $ ideaSpan i) where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs list mode = zipWithFrom f 0 where f i (name,n) = "
  • " ++ escapeHTML name ++ " (" ++ show n ++ ")
  • " where id = mode ++ show i writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} = ["
    " ,escapeHTML (GHC.showSrcSpan ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "
    " ,"Found
    " ,hsColourHTML ideaFrom] ++ (case ideaTo of Nothing -> [] Just to -> ["Perhaps" ++ (if to == "" then " you should remove it." else "") ++ "
    " ,hsColourHTML to]) ++ [let n = showNotes ideaNote in if n /= "" then "Note: " ++ writeNote n ++ "" else "" ,"
    " ,""] -- Unescaped, but may have `backticks` for code writeNote :: String -> String writeNote = f . splitOn "`" where f (a:b:c) = escapeHTML a ++ "" ++ escapeHTML b ++ "" ++ f c f xs = concatMap escapeHTML xs hlint-3.5/src/Summary.hs0000644000000000000000000001461707346545000013461 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DataKinds #-} module Summary (generateMdSummary, generateJsonSummary, generateExhaustiveConfig) where import qualified Data.Map as Map import Control.Monad.Extra import System.FilePath 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 head . 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 = [""] ++ xs ++ [""] -- | Render using if it is single-line, otherwise using
    .
    haskell :: String -> [String]
    haskell s
      | '\n' `elem` s = ["
    ", s, "
    "] | otherwise = ["", s, "", "
    "] builtinTable :: [BuiltinHint] -> [String] builtinTable builtins = [""] ++ row ["", "", ""] ++ concatMap showBuiltin builtins ++ ["
    Hint NameHintSeverity
    "] showBuiltin :: BuiltinHint -> [String] showBuiltin BuiltinHint{..} = row1 where row1 = row $ [ "" ++ hName ++ "", ""] ++ showExample (head hExamples) ++ ["Does not support refactoring." | not hRefactoring] ++ [""] ++ [ "" ++ show hSeverity ++ "" ] 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 = [""] ++ row ["", "", ""] ++ concatMap showLhsRhs hints ++ ["
    Hint NameHintSeverity
    "] showLhsRhs :: HintRule -> [String] showLhsRhs HintRule{..} = row $ [ "" ++ hintRuleName ++ "" , "" , "LHS:" ] ++ haskell (show hintRuleLHS) ++ ["RHS:"] ++ haskell (show hintRuleRHS) ++ [ "" , "" ++ show hintRuleSeverity ++ "" ] hlint-3.5/src/Test/0000755000000000000000000000000007346545000012376 5ustar0000000000000000hlint-3.5/src/Test/All.hs0000644000000000000000000000675407346545000013456 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Test.All(test) where import Control.Exception 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 import Prelude import Config.Type import Config.Read import CmdLine import Refact import Hint.All import Test.Annotations 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 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" let useSrc = hasSrc && null files testFiles <- if files /= [] then pure files else do xs <- liftIO $ getDirectoryContents dataDir pure [dataDir x | x <- xs, takeExtension x `elem` [".yml",".yaml"]] testFiles <- liftIO $ forM testFiles $ \file -> do 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 (" ++ (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") (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 (eitherToMaybe rpath) when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" 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 " ++ unsafePrettyPrint hintRuleLHS ++ " ==> " ++ unsafePrettyPrint hintRuleRHS] | SettingMatchExp x@HintRule{..} <- hints, hintRuleName == defaultHintName] -- Check that the default.yaml template I supply is valid when I strip off all the comments, since that's -- what a user gets with --default checkCommentedYaml :: FilePath -> IO () checkCommentedYaml file = do src <- lines <$> readFile' file let src2 = [x | x <- src, Just x <- [stripPrefix "# " x], not $ all (\x -> isAlpha x || x == '$') $ take 1 x] e <- readFilesConfig [(file, Just $ unlines src2)] void $ evaluate $ length e hlint-3.5/src/Test/Annotations.hs0000644000000000000000000002027507346545000015235 0ustar0000000000000000{-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-} -- | Check the annotations within source and hint files. module Test.Annotations(testAnnotations, parseTestFile, TestCase(..)) where import Control.Exception.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 Data.Tuple.Extra import System.Exit import System.FilePath import System.IO.Extra import GHC.All import qualified Data.ByteString.Char8 as BS import Config.Type import Idea import Apply import Extension import Refact import Test.Util 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 Refactor String (Maybe String) [Setting] deriving (Show) 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 refact inp out additionalSettings) = do ideas <- liftIO $ try_ $ do res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp evaluate $ length $ show res pure res let good = case (out, ideas) of (Nothing, Right []) -> True (Just x, Right [idea]) | match x idea -> True _ -> False let bad = [failed $ ["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)" ,"SRC: " ++ unsafePrettyPrint loc ,"INPUT: " ++ inp] ++ map ("OUTPUT: " ++) (either (pure . show) (map show) ideas) ++ ["WANTED: " ++ fromMaybe "" out] | not good] ++ [failed ["TEST FAILURE (BAD LOCATION)" ,"SRC: " ++ unsafePrettyPrint loc ,"INPUT: " ++ inp ,"OUTPUT: " ++ show i] | 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] match "@NoNote" i = null (ideaNote i) match (word1 -> ('@':sev, msg)) i = sev == show (ideaSeverity i) && match msg i match msg i = on (==) norm (fromMaybe "" $ ideaTo i) msg -- FIXME: Should use a better check for expected results norm = filter $ \x -> not (isSpace x) && x /= ';' parseTestFile :: FilePath -> IO [TestCase] parseTestFile file = -- we remove all leading # symbols since Yaml only lets us do comments that way f Nothing TestRefactor . zipFrom 1 . map (dropPrefix "# ") . lines <$> readFile file where open :: String -> Maybe [Setting] open line | "" `isPrefixOf` line = let suffix = dropPrefix "" line 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] | otherwise = Nothing shut :: String -> Bool shut = isPrefixOf "" 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 :: 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 "" x = first ("--"++) $ f x 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 fuction"). 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] _ -> [] hlint-3.5/src/Test/InputOutput.hs0000644000000000000000000001042107346545000015250 0ustar0000000000000000{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-} -- | Check the input/output pairs in the tests/ directory module Test.InputOutput(testInputOutput) where import Control.Applicative import Data.Tuple.Extra import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.List.Extra import Data.IORef import System.Directory import System.FilePath import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Verbosity import System.Exit import System.IO.Extra import Prelude import Test.Util testInputOutput :: ([String] -> IO ()) -> Test () testInputOutput main = do xs <- liftIO $ getDirectoryContents "tests" xs <- pure $ filter ((==) ".test" . takeExtension) xs forM_ xs $ \file -> do ios <- liftIO $ parseInputOutputs <$> readFile ("tests" file) forM_ (zipFrom 1 ios) $ \(i,io@InputOutput{..}) -> do progress liftIO $ forM_ files $ \(name,contents) -> do createDirectoryIfMissing True $ takeDirectory name writeFile name contents checkInputOutput main io{name= "_" ++ takeBaseName file ++ "_" ++ show i} liftIO $ mapM_ (removeFile . fst) $ concatMap files ios data InputOutput = InputOutput {name :: String ,files :: [(FilePath, String)] ,run :: [String] ,output :: String ,exit :: Maybe ExitCode } deriving Eq parseInputOutputs :: String -> [InputOutput] parseInputOutputs = f z . lines where z = InputOutput "unknown" [] [] "" Nothing interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"] 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 f io ((stripPrefix "FILE " -> Just file):xs) | (str,xs) <- g xs = f io{files = files io ++ [(file,unlines str)]} xs f io ("OUTPUT":xs) | (str,xs) <- g xs = f io{output = unlines str} xs f io ((isPrefixOf "----" -> True):xs) = [io | io /= z] ++ f z xs f io [] = [io | io /= z] f io (x:xs) = error $ "Unknown test item, " ++ x g = first (reverse . dropWhile null . reverse) . break interest --------------------------------------------------------------------- -- CHECK INPUT/OUTPUT PAIRS checkInputOutput :: ([String] -> IO ()) -> InputOutput -> Test () checkInputOutput main InputOutput{..} = do code <- liftIO $ newIORef ExitSuccess got <- liftIO $ fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $ handle (\(e::SomeException) -> print e) $ handle (\(e::ExitCode) -> writeIORef code e) $ bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run code <- liftIO $ readIORef code (want,got) <- pure $ matchStarStar (lines output) got if maybe False (/= code) exit then failed ["TEST FAILURE IN tests/" ++ name ,"WRONG EXIT CODE" ,"GOT : " ++ show code ,"WANT: " ++ show exit ] else if length got == length want && and (zipWith matchStar want got) then passed else do let trail = replicate (max (length got) (length want)) "" let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g] failed $ ["TEST FAILURE IN tests/" ++ name ,"DIFFER ON LINE: " ++ show i ,"GOT : " ++ g ,"WANT: " ++ w ,"FULL OUTPUT FOR GOT:"] ++ got -- | First string may have stars in it (the want) matchStar :: String -> String -> Bool matchStar ('*':xs) ys = any (matchStar xs) $ tails 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 matchStarStar :: [String] -> [String] -> ([String], [String]) matchStarStar want got = case break (== "**") want of (_, []) -> (want, got) (w1,_:w2) -> (w1++w2, g1 ++ takeEnd (length w2) g2) where (g1,g2) = splitAt (length w1) got hlint-3.5/src/Test/Util.hs0000644000000000000000000000226307346545000013652 0ustar0000000000000000{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-} module Test.Util( Test, withTests, passed, failed, progress, ) where import Idea import Control.Monad import Control.Monad.Trans.Reader import Control.Monad.IO.Class import Data.IORef data S = S {failures :: !Int ,total :: !Int ,ideas :: [[Idea]] } newtype Test a = Test (ReaderT (IORef S) IO a) deriving (Functor, Applicative, Monad, MonadIO) -- | Returns the number of failing tests. withTests :: Test a -> IO (Int, a) withTests (Test act) = do ref <- newIORef $ S 0 0 [] res <- runReaderT act ref S{..} <- readIORef ref putStrLn "" putStrLn $ if failures == 0 then "Tests passed (" ++ show total ++ ")" else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")" pure (failures, res) progress :: Test () progress = liftIO $ putChar '.' passed :: Test () passed = do ref <- Test ask liftIO $ modifyIORef' ref $ \s -> s{total=total s+1} failed :: [String] -> Test () failed xs = do unless (null xs) $ liftIO $ putStrLn $ unlines $ "" : xs ref <- Test ask liftIO $ modifyIORef' ref $ \s -> s{total=total s+1, failures=failures s+1} hlint-3.5/src/Timing.hs0000644000000000000000000000417407346545000013250 0ustar0000000000000000 module Timing( timed, timedIO, startTimings, printTimings ) where import qualified Data.HashMap.Strict as Map import Control.Exception import Data.IORef.Extra import Data.Tuple.Extra import Data.List.Extra import Control.Monad import System.Console.CmdArgs.Verbosity import System.Time.Extra import System.IO.Unsafe import System.IO type Category = String type Item = String {-# NOINLINE useTimingsRef #-} useTimingsRef :: IORef Bool useTimingsRef = unsafePerformIO $ newIORef False {-# NOINLINE useTimings #-} useTimings :: Bool useTimings = unsafePerformIO $ readIORef useTimingsRef {-# NOINLINE timings #-} timings :: IORef (Map.HashMap (Category, Item) Seconds) timings = unsafePerformIO $ newIORef Map.empty {-# NOINLINE timed #-} timed :: Category -> Item -> a -> a timed c i x = if not useTimings then x else unsafePerformIO $ timedIO c i $ evaluate x 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 $ do putStr $ "# " ++ c ++ " of " ++ i ++ "... " hFlush stdout (time, x) <- duration x atomicModifyIORef'_ timings $ Map.insertWith (+) (c, i) time unless quiet $ whenLoud $ putStrLn $ "took " ++ showDuration time pure x startTimings :: IO () startTimings = do writeIORef useTimingsRef True writeIORef timings Map.empty printTimings :: IO () printTimings = do mp <- readIORef timings let items = sortOn (sumSnd . snd) $ groupSort $ map (\((a,b),c) -> (a,(b,c))) $ Map.toList mp putStrLn $ unlines $ intercalate [""] $ map disp $ items ++ [("TOTAL", map (second sumSnd) items)] where sumSnd = sum . map snd disp (cat,xs) = ("Timing " ++ cat) : [" " ++ showDuration b ++ " " ++ a | (a,b) <- xs2] ++ [" " ++ showDuration (sumSnd xs2) ++ " TOTAL"] where xs2 = f $ splitAt 9 $ sortOn (negate . snd) xs f (xs,ys) | length ys <= 1 = xs ++ ys | otherwise = xs ++ [("Other items (" ++ show (length ys) ++ ")", sumSnd ys)] hlint-3.5/src/Util.hs0000644000000000000000000000452307346545000012734 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, Rank2Types #-} module Util( forceList, gzip, universeParentBi, exitMessage, exitMessageImpure, getContentsUTF8, wildcardMatch ) where import System.Exit import System.IO import System.IO.Unsafe import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.DataOnly import System.FilePattern import Data.List.Extra --------------------------------------------------------------------- -- CONTROL.DEEPSEQ forceList :: [a] -> [a] forceList xs = length xs `seq` xs --------------------------------------------------------------------- -- SYSTEM.IO exitMessage :: String -> IO a exitMessage msg = do hPutStrLn stderr msg exitWith $ ExitFailure 1 exitMessageImpure :: String -> a exitMessageImpure = unsafePerformIO . exitMessage getContentsUTF8 :: IO String getContentsUTF8 = do hSetEncoding stdin utf8 getContents --------------------------------------------------------------------- -- DATA.GENERICS data Box = forall a . Data a => Box a gzip :: Data a => (forall b . Data b => b -> b -> c) -> a -> a -> Maybe [c] gzip f x y | toConstr x /= toConstr y = Nothing | otherwise = Just $ zipWith op (gmapQ Box x) (gmapQ Box y) -- unsafeCoerce is safe because gmapQ on the same constr gives the same fields -- in the same order where op (Box x) (Box y) = f x (unsafeCoerce y) --------------------------------------------------------------------- -- DATA.GENERICS.UNIPLATE.OPERATIONS universeParent :: Data a => a -> [(Maybe a, a)] universeParent x = (Nothing,x) : f x where f :: Data a => a -> [(Maybe a, a)] f x = concat [(Just x, y) : f y | y <- children x] universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi --------------------------------------------------------------------- -- SYSTEM.FILEPATTERN -- | 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: . wildcardMatch :: FilePattern -> String -> Bool wildcardMatch p m = let f = replace "." "/" in f p ?== f m hlint-3.5/tests/0000755000000000000000000000000007346545000012032 5ustar0000000000000000hlint-3.5/tests/bracket.test0000644000000000000000000000116407346545000014350 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/cmdline.test0000644000000000000000000000104207346545000014343 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/cpp.test0000644000000000000000000000536207346545000013523 0ustar0000000000000000--------------------------------------------------------------------- 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: Unsupported extension: Foo Found: {-# LANGUAGE CPP #-} {-# LANGUAGE Foo #-} main = undefined 1 hint --------------------------------------------------------------------- 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 hlint-3.5/tests/cross.test0000644000000000000000000000052307346545000014064 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/find.test0000644000000000000000000000201407346545000013650 0ustar0000000000000000--------------------------------------------------------------------- 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"} hlint-3.5/tests/flag-extension.test0000644000000000000000000000120707346545000015656 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/flag-no-summary.test0000644000000000000000000000072307346545000015753 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/flag-only.test0000644000000000000000000000152507346545000014626 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/flag-quiet.test0000644000000000000000000000024507346545000014772 0ustar0000000000000000--------------------------------------------------------------------- RUN tests/flag-quiet.hs --quiet FILE tests/flag-quiet.hs main = map f $ map g xs OUTPUT EXIT 1 hlint-3.5/tests/flag-with-group.test0000644000000000000000000000103307346545000015744 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/hint.test0000644000000000000000000001567207346545000013710 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/hintrule-implies-classify.test0000644000000000000000000000051207346545000020036 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/import_style.test0000644000000000000000000000433007346545000015465 0ustar0000000000000000--------------------------------------------------------------------- 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 --------------------------------------------------------------------- hlint-3.5/tests/json.test0000644000000000000000000000630707346545000013712 0ustar0000000000000000--------------------------------------------------------------------- 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\"}]"}] hlint-3.5/tests/lhs.test0000644000000000000000000000162107346545000013521 0ustar0000000000000000--------------------------------------------------------------------- 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 hint --------------------------------------------------------------------- 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 hlint-3.5/tests/no_explicit_cpp.test0000644000000000000000000000076607346545000016123 0ustar0000000000000000--------------------------------------------------------------------- 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 hlint-3.5/tests/parse-error.test0000644000000000000000000000150707346545000015177 0ustar0000000000000000--------------------------------------------------------------------- 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 hint --------------------------------------------------------------------- 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: Unsupported extension: InvalidExtension Found: {-# LANGUAGE InvalidExtension #-} 1 hint hlint-3.5/tests/serialise.test0000644000000000000000000001313307346545000014714 0ustar0000000000000000--------------------------------------------------------------------- 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}}])] hlint-3.5/tests/wildcards.test0000644000000000000000000003636107346545000014720 0ustar0000000000000000---- 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