diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,5 +1,29 @@
Changelog for HLint (* = breaking change)
+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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -96,26 +96,14 @@
### Automatically Applying Hints
-By supplying the `--refactor` flag hlint can automatically apply most
-suggestions. Instead of a list of hints, hlint will instead output the
-refactored file on stdout. In order to do this, it is necessary to have the
-`refactor` executable on your path. `refactor` is provided by the
-[`apply-refact`](https://github.com/mpickering/apply-refact) package,
-it uses the GHC API in order to transform source files given a list of
-refactorings to apply. Hlint directly calls the executable to apply the
-suggestions.
-
-Additional configuration can be passed to `refactor` with the
-`--refactor-options` flag. Some useful flags include `-i` which replaces the
-original file and `-s` which asks for confirmation before performing a hint.
+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.
-An alternative location for `refactor` can be specified with the
-`--with-refactor` flag.
+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.
-Simple bindings for [vim](https://github.com/mpickering/hlint-refactor-vim),
-[emacs](https://github.com/mpickering/hlint-refactor-mode) and [atom](https://github.com/mpickering/hlint-refactor-atom) are provided.
+While the `--refactor` flag is useful, it is not complete or at the same level of quality as the rest of HLint:
-There are no plans to support the duplication nor the renaming hints.
+* Some hints don't generate refactorings. Examples include excess duplication, renaming hints and eta reduction hints.
+* There are bugs in the underlying `refactor` tool which cause the resultant file to be incorrect. For example, `[1,2..3]` comes out as `[12..3]` ([#389](https://github.com/ndmitchell/hlint/issues/389)), even if there isn't a hint that touches it.
### Reports
diff --git a/data/hlint.yaml b/data/hlint.yaml
--- a/data/hlint.yaml
+++ b/data/hlint.yaml
@@ -204,6 +204,8 @@
- 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}
@@ -227,6 +229,8 @@
- warn: {lhs: zipWith f (repeat x), rhs: map (f x)}
- warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y}
- warn: {lhs: 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, name: Redundant take}
# MONOIDS
@@ -241,7 +245,6 @@
- warn: {lhs: sequenceA (map f x), rhs: traverse f x}
- warn: {lhs: sequenceA (fmap f x), rhs: traverse f x}
- - warn: {lhs: sequence (fmap f x), rhs: traverse f x}
- warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x}
- warn: {lhs: sequenceA_ (fmap f x), rhs: traverse_ f x}
- warn: {lhs: foldMap id, rhs: fold}
@@ -485,6 +488,10 @@
- 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}
@@ -511,6 +518,8 @@
- hint: {lhs: pure . f =<< m, rhs: f <$> m}
- warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"}
- warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}
+ - warn: {lhs: traverse id, rhs: sequenceA}
+ - warn: {lhs: traverse_ id, rhs: sequenceA_}
# LIST COMP
@@ -544,8 +553,8 @@
- warn: {lhs: maybe True (x /=), rhs: (Just x /=)}
- warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x}
- warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x}
- - warn: {lhs: fromMaybe False, rhs: (Just True ==)}
- - warn: {lhs: fromMaybe True, rhs: (Just False /=)}
+ - warn: {lhs: fromMaybe False x, rhs: Just True == x} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053
+ - warn: {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}
@@ -987,6 +996,13 @@
- 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}
+- 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
@@ -1039,6 +1055,8 @@
# 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)
@@ -1100,8 +1118,7 @@
# 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 |]) @NoRefactor: apply-refact requires TemplateHaskell pragma
-# {-# LANGUAGE TemplateHaskell #-}; main = map $ \ d -> ([| $d |], [| $d |])
+# 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 ???
@@ -1152,6 +1169,9 @@
# 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
# import Prelude \
# yes = flip mapM -- Control.Monad.forM
@@ -1194,10 +1214,14 @@
# fromList [] -- Data.Map.Lazy.empty
# import Data.Map.Strict (fromList) \
# fromList [] -- Data.Map.Strict.empty
-# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n} @NoRefactor
+# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n}
# f = map (flip (,) "a") "123" -- (,"a")
# f = map ((,) "a") "123" -- ("a",)
-# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here @NoRefactor
+# 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 |]
#
diff --git a/hlint.cabal b/hlint.cabal
--- a/hlint.cabal
+++ b/hlint.cabal
@@ -1,7 +1,7 @@
cabal-version: >= 1.18
build-type: Simple
name: hlint
-version: 3.1.4
+version: 3.1.5
license: BSD3
license-file: LICENSE
category: Development
@@ -48,6 +48,11 @@
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:
@@ -59,10 +64,9 @@
data-default >= 0.3,
cpphs >= 1.20.1,
cmdargs >= 0.10,
- yaml >= 0.5.0,
uniplate >= 1.5,
ansi-terminal >= 0.6.2,
- extra >= 1.7.1,
+ extra >= 1.7.3,
refact >= 0.3,
aeson >= 1.1.2.0,
filepattern >= 0.1.1
@@ -76,13 +80,21 @@
build-depends:
ghc-lib-parser == 8.10.*
build-depends:
- ghc-lib-parser-ex >= 8.10.0.11 && < 8.10.1
+ ghc-lib-parser-ex >= 8.10.0.14 && < 8.10.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
@@ -109,20 +121,19 @@
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.Module
GHC.Util.SrcLoc
- GHC.Util.DynFlags
GHC.Util.Scope
GHC.Util.Unify
- HSE.All
Hint.All
Hint.Bracket
Hint.Comment
diff --git a/src/Apply.hs b/src/Apply.hs
--- a/src/Apply.hs
+++ b/src/Apply.hs
@@ -3,10 +3,10 @@
import Control.Applicative
import Data.Monoid
-import HSE.All
+import GHC.All
import Hint.All
import GHC.Util
-import Data.Generics.Uniplate.Data
+import Data.Generics.Uniplate.DataOnly
import Idea
import Data.Tuple.Extra
import Data.Either
@@ -15,8 +15,9 @@
import Data.Ord
import Config.Type
import Config.Haskell
+import SrcLoc
import GHC.Hs
-import qualified SrcLoc as GHC
+import Language.Haskell.GhclibParserEx.GHC.Hs
import qualified Data.HashSet as Set
import Prelude
@@ -51,7 +52,7 @@
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 $ GHC.unLoc $ ghcModule m]
+ 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
@@ -62,7 +63,7 @@
where
f = nubOrd . filter (/= "")
cls = [x | SettingClassify x <- settings]
- mns = map (\x -> (scopeCreate (GHC.unLoc $ ghcModule x), x)) ms
+ mns = map (\x -> (scopeCreate (unLoc $ ghcModule x), x)) ms
hints = (if length ms <= 1 then noModules else id) hints_
noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}
diff --git a/src/CmdLine.hs b/src/CmdLine.hs
--- a/src/CmdLine.hs
+++ b/src/CmdLine.hs
@@ -14,7 +14,7 @@
import Data.List.Extra
import Data.Maybe
import Data.Functor
-import HSE.All(CppFlags(..))
+import GHC.All(CppFlags(..))
import GHC.LanguageExtensions.Type
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx
import DynFlags hiding (verbosity)
@@ -323,6 +323,15 @@
ls = [(show x, x) | x <- [Haskell98, Haskell2010]]
f (a, e) "Haskell98" = ([], [])
- f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x = (delete x a, x : delete x e)
+ 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 = (a, e) -- Ignore unknown 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 TemplateHaskell = [TemplateHaskell, TemplateHaskellQuotes]
+ expandDisable x = [x]
diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs
--- a/src/Config/Compute.hs
+++ b/src/Config/Compute.hs
@@ -4,11 +4,11 @@
-- | Given a file, guess settings from it by looking at the hints.
module Config.Compute(computeSettings) where
-import HSE.All
+import GHC.All
import GHC.Util
import Config.Type
import Fixity
-import Data.Generics.Uniplate.Data
+import Data.Generics.Uniplate.DataOnly
import GHC.Hs hiding (Warning)
import RdrName
import Name
diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs
--- a/src/Config/Yaml.hs
+++ b/src/Config/Yaml.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}
+{-# LANGUAGE CPP #-}
module Config.Yaml(
ConfigYaml,
@@ -8,19 +9,17 @@
) where
import Config.Type
-import Data.Yaml
import Data.Either
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Control.Monad.Extra
-import Control.Exception.Extra
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as Map
-import Data.Generics.Uniplate.Data
-import HSE.All
+import Data.Generics.Uniplate.DataOnly
+import GHC.All
import Fixity
import Extension
import Module
@@ -41,6 +40,33 @@
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Data.Char
+
+#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
-- | Read a config file in YAML format. Takes a filename, and optionally the contents.
diff --git a/src/Extension.hs b/src/Extension.hs
--- a/src/Extension.hs
+++ b/src/Extension.hs
@@ -24,6 +24,9 @@
{- , 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 except avoiding passing it to apply-refact.
+ -- See https://github.com/mpickering/apply-refact/issues/58
]
-- | Extensions we turn on by default when parsing. Aim to parse as
diff --git a/src/GHC/All.hs b/src/GHC/All.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/All.hs
@@ -0,0 +1,205 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module GHC.All(
+ CppFlags(..), ParseFlags(..), defaultParseFlags,
+ parseFlagsAddFixities, parseFlagsSetLanguage,
+ ParseError(..), ModuleEx(..),
+ parseModuleEx, createModuleEx, ghcComments,
+ parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
+ ) where
+
+import Util
+import Data.Char
+import Data.List.Extra
+import Timing
+import Language.Preprocessor.Cpphs
+import qualified Data.Map as Map
+import System.IO.Extra
+import Fixity
+import Extension
+import FastString
+
+import GHC.Hs
+import SrcLoc
+import ErrUtils
+import Outputable
+import Lexer hiding (context)
+import GHC.LanguageExtensions.Type
+import ApiAnnotation
+import DynFlags hiding (extensions)
+import Bag
+
+import Language.Haskell.GhclibParserEx.GHC.Parser
+import Language.Haskell.GhclibParserEx.Fixity
+import GHC.Util
+
+-- | What C pre processor should be used.
+data CppFlags
+ = NoCpp -- ^ No pre processing is done.
+ | CppSimple -- ^ Lines prefixed with @#@ are stripped.
+ | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.
+
+-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
+data ParseFlags = ParseFlags
+ {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
+ ,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 NoCpp 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 NoCpp _ x = pure x
+runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
+runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
+ where
+ -- LINE pragmas always inserted when locations=True
+ 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.
+data ModuleEx = ModuleEx {
+ ghcModule :: Located (HsModule GhcPs)
+ , ghcAnnotations :: ApiAnns
+}
+
+-- | Extract a list of all of a parsed module's comments.
+ghcComments :: ModuleEx -> [Located AnnotationComment]
+ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))
+
+
+-- | The error handler invoked when GHC parsing has failed.
+ghcFailOpParseModuleEx :: String
+ -> FilePath
+ -> String
+ -> (SrcSpan, ErrUtils.MsgDoc)
+ -> IO (Either ParseError ModuleEx)
+ghcFailOpParseModuleEx ppstr file str (loc, err) = do
+ let pe = case loc of
+ RealSrcSpan r -> context (srcSpanStartLine r) ppstr
+ _ -> ""
+ msg = Outputable.showSDoc baseDynFlags err
+ pure $ Left $ ParseError loc msg pe
+
+-- GHC extensions to enable/disable given HSE parse flags.
+ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
+ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)
+
+-- GHC fixities given HSE parse flags.
+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, 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 GHC annotations and module tree. It
+-- is assumed the incoming parse module has not been adjusted to
+-- account for operator fixities (it uses the HLint default fixities).
+createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
+createModuleEx anns ast =
+ ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns
+
+-- | 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 $ do
+ str <- case str of
+ Just x -> pure x
+ Nothing | file == "-" -> getContentsUTF8
+ | otherwise -> readFileUTF8' file
+ str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130
+ ppstr <- runCpp (cppFlags flags) file str
+ let enableDisableExts = ghcExtensionsFromParseFlags flags
+ dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr
+ case dynFlags of
+ Right ghcFlags -> do
+ ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags
+ case fileToModule file ppstr ghcFlags of
+ POk s a -> do
+ let errs = bagToList . snd $ getMessages s ghcFlags
+ if not $ null errs then
+ handleParseFailure ghcFlags ppstr file str errs
+ else do
+ let anns =
+ ( Map.fromListWith (++) $ annotations s
+ , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)
+ )
+ let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
+ pure $ Right (ModuleEx (applyFixities fixes a) anns)
+ PFailed s ->
+ handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags
+ Left msg -> do
+ -- Parsing GHC flags from dynamic pragmas in the source
+ -- has failed. When this happens, it's reported by
+ -- exception. It's impossible or at least fiddly getting a
+ -- location so we skip that for now. Synthesize a parse
+ -- error.
+ let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)
+ pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)
+ where
+ handleParseFailure ghcFlags ppstr file str errs =
+ let errMsg = head errs
+ loc = errMsgSpan errMsg
+ doc = formatErrDoc ghcFlags (errMsgDoc 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) [" "," ","> "," "," "]
diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs
--- a/src/GHC/Util.hs
+++ b/src/GHC/Util.hs
@@ -7,7 +7,6 @@
, module GHC.Util.ApiAnnotation
, module GHC.Util.HsDecl
, module GHC.Util.HsExpr
- , module GHC.Util.Module
, module GHC.Util.SrcLoc
, module GHC.Util.DynFlags
, module GHC.Util.Scope
@@ -24,7 +23,6 @@
import GHC.Util.ApiAnnotation
import GHC.Util.HsExpr
import GHC.Util.HsDecl
-import GHC.Util.Module
import GHC.Util.SrcLoc
import GHC.Util.DynFlags
import GHC.Util.Scope
diff --git a/src/GHC/Util/DynFlags.hs b/src/GHC/Util/DynFlags.hs
--- a/src/GHC/Util/DynFlags.hs
+++ b/src/GHC/Util/DynFlags.hs
@@ -3,7 +3,7 @@
import DynFlags
import GHC.LanguageExtensions.Type
import Data.List.Extra
-import Language.Haskell.GhclibParserEx.Config
+import Language.Haskell.GhclibParserEx.GHC.Settings.Config
baseDynFlags :: DynFlags
baseDynFlags =
diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs
--- a/src/GHC/Util/FreeVars.hs
+++ b/src/GHC/Util/FreeVars.hs
@@ -15,8 +15,7 @@
import SrcLoc
import Bag (bagToList)
-import Data.Generics.Uniplate.Data ()
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.Monoid
import Data.Semigroup
import Data.List.Extra
diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs
--- a/src/GHC/Util/HsExpr.hs
+++ b/src/GHC/Util/HsExpr.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module GHC.Util.HsExpr (
@@ -22,14 +23,14 @@
import Bag(bagToList)
import GHC.Util.Brackets
-import GHC.Util.View
import GHC.Util.FreeVars
+import GHC.Util.View
import Control.Applicative
import Control.Monad.Trans.State
import Data.Data
-import Data.Generics.Uniplate.Data
+import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Tuple.Extra
@@ -148,9 +149,8 @@
-- Implementation. Try to produce special forms (e.g. sections,
-- compositions) where we can.
niceLambdaR :: [String]
- -> LHsExpr GhcPs
- -> (LHsExpr GhcPs, R.SrcSpan
- -> [Refactoring R.SrcSpan])
+ -> 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
@@ -174,7 +174,8 @@
, vars e `disjoint` [v]
, L _ (HsVar _ (L _ fname)) <- f
, isSymOcc $ rdrNameOcc fname
- = (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)])
+ = let res = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f
+ in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)])
-- @\vs v -> f x v@ ==> @\vs -> f x@
niceLambdaR (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))
@@ -290,12 +291,20 @@
g1 = (fst .) . g
g2 = (snd .) . g
- f i (L _ (HsPar _ y)) z | not $ needBracketOld i x y = (y, z)
- f i y z | needBracketOld i x y = (addParen y, addParen z)
+ f i (L _ (HsPar _ y)) z
+ | not $ needBracketOld i x y = (y, z)
+ f i y z
+ | needBracketOld i x y = (addParen y, addParen z)
+ -- https://github.com/mpickering/apply-refact/issues/7
+ | isOp y = (y, addParen z)
f _ y z = (y, z)
f1 = ((fst .) .) . f
f2 = ((snd .) .) . f
+
+ isOp = \case
+ L _ (HsVar _ (L _ name)) -> isSymbolRdrName name
+ _ -> False
fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 (L _ (HsPar _ x)) = x
diff --git a/src/GHC/Util/Module.hs b/src/GHC/Util/Module.hs
deleted file mode 100644
--- a/src/GHC/Util/Module.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-
-module GHC.Util.Module (modName, fromModuleName') where
-
-import GHC.Hs
-import Module
-import SrcLoc
-
-modName :: Located (HsModule GhcPs) -> String
-modName (L _ HsModule {hsmodName=Nothing}) = "Main"
-modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n
-
-fromModuleName' :: Located ModuleName -> String
-fromModuleName' (L _ n) = moduleNameString n
diff --git a/src/GHC/Util/Scope.hs b/src/GHC/Util/Scope.hs
--- a/src/GHC/Util/Scope.hs
+++ b/src/GHC/Util/Scope.hs
@@ -15,7 +15,6 @@
import RdrName
import OccName
-import GHC.Util.Module
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
@@ -47,7 +46,7 @@
-- Predicate to test for a 'Prelude' import declaration.
isPrelude :: LImportDecl GhcPs -> Bool
- isPrelude (L _ x) = fromModuleName' (ideclName x) == "Prelude"
+ 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
@@ -58,7 +57,7 @@
| isSpecial x && isSpecial y = rdrNameStr x == rdrNameStr y
| isSpecial x || isSpecial y = False
| otherwise =
- rdrNameStr (unqual x) == rdrNameStr (unqual y) && not (possModules a x `disjoint` possModules b y)
+ 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
diff --git a/src/GHC/Util/SrcLoc.hs b/src/GHC/Util/SrcLoc.hs
--- a/src/GHC/Util/SrcLoc.hs
+++ b/src/GHC/Util/SrcLoc.hs
@@ -10,7 +10,7 @@
import Data.Default
import Data.Data
-import Data.Generics.Uniplate.Data
+import Data.Generics.Uniplate.DataOnly
-- 'stripLocs x' is 'x' with all contained source locs replaced by
-- 'noSrcSpan'.
diff --git a/src/GHC/Util/Unify.hs b/src/GHC/Util/Unify.hs
--- a/src/GHC/Util/Unify.hs
+++ b/src/GHC/Util/Unify.hs
@@ -9,7 +9,7 @@
import Control.Applicative
import Control.Monad
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.Char
import Data.Data
import Data.List.Extra
@@ -26,6 +26,7 @@
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.HsExpr
import GHC.Util.View
+import FastString
isUnifyVar :: String -> Bool
isUnifyVar [x] = x == '?' || isAlpha x
@@ -105,6 +106,7 @@
| 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
| Just (x :: SrcSpan) <- cast x = Just mempty
| otherwise = unifyDef' nm x y
@@ -149,17 +151,19 @@
-- Unify a function application where the function is a composition of functions.
unifyComposed
| (L _ (OpApp _ y11 dot y12)) <- fromParen y1, isDot dot =
- -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.
- -- The guard ensures that you don't get duplicate matches because the matching engine
- -- auto-generates hints in dot-form.
- (guard (not root) >> (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2)))))
- -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',
- -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',
- -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.
- <|> do
- rhs <- unifyExp' nm False x2 y2
- (lhs, extra) <- unifyComposed' nm x1 y11 dot y12
- pure (lhs <> rhs, extra)
+ 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 (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))
+ else do
+ -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',
+ -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',
+ -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.
+ -- You can only add to extra if you are at the root (otherwise 'extra' has nowhere to go).
+ rhs <- unifyExp' nm False x2 y2
+ (lhs, extra) <- unifyComposed' nm x1 y11 dot y12
+ pure (lhs <> rhs, extra)
| otherwise = Nothing
-- Options: match directly, then expand through '$', then desugar infix.
@@ -170,11 +174,16 @@
| otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 lhs2)) rhs2)
unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y
+-- | 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) )
+unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs))
-- Brackets are not added when expanding '$' in user code, so tolerate
-- them in the match even if they aren't in the user code.
unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen x) y
@@ -185,7 +194,7 @@
unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr -> v))) rhs1))
y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) =
- fst <$> unifyExp nm root x y
+ 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
@@ -194,10 +203,10 @@
| isUnifyVar v = (Subst [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2
unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) =
- fst <$> unifyExp nm root x y
+ noExtra $ unifyExp nm root x y
unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) =
- fst <$> unifyExp nm root x y
+ noExtra $ unifyExp nm root x y
unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y
where
diff --git a/src/Grep.hs b/src/Grep.hs
--- a/src/Grep.hs
+++ b/src/Grep.hs
@@ -4,7 +4,7 @@
import Hint.All
import Apply
import Config.Type
-import HSE.All
+import GHC.All
import Control.Monad
import Data.List
import Util
diff --git a/src/HLint.hs b/src/HLint.hs
--- a/src/HLint.hs
+++ b/src/HLint.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
@@ -31,7 +32,7 @@
import Timing
import Test.Proof
import Parallel
-import HSE.All
+import GHC.All
import CC
import EmbedData
@@ -194,9 +195,9 @@
let hints = show $ map (show &&& ideaRefactoring) ideas
withTempFile $ \f -> do
writeFile f hints
- exitWith =<< runRefactoring path file f cmdRefactorOptions
+ 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
diff --git a/src/HSE/All.hs b/src/HSE/All.hs
deleted file mode 100644
--- a/src/HSE/All.hs
+++ /dev/null
@@ -1,205 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module HSE.All(
- CppFlags(..), ParseFlags(..), defaultParseFlags,
- parseFlagsAddFixities, parseFlagsSetLanguage,
- ParseError(..), ModuleEx(..),
- parseModuleEx, createModuleEx, ghcComments,
- parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
- ) where
-
-import Util
-import Data.Char
-import Data.List.Extra
-import Timing
-import Language.Preprocessor.Cpphs
-import qualified Data.Map as Map
-import System.IO.Extra
-import Fixity
-import Extension
-import FastString
-
-import GHC.Hs
-import SrcLoc
-import ErrUtils
-import Outputable
-import Lexer hiding (context)
-import GHC.LanguageExtensions.Type
-import ApiAnnotation
-import DynFlags hiding (extensions)
-import Bag
-
-import Language.Haskell.GhclibParserEx.GHC.Parser
-import Language.Haskell.GhclibParserEx.Fixity
-import GHC.Util
-
--- | What C pre processor should be used.
-data CppFlags
- = NoCpp -- ^ No pre processing is done.
- | CppSimple -- ^ Lines prefixed with @#@ are stripped.
- | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.
-
--- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
-data ParseFlags = ParseFlags
- {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
- ,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 NoCpp 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 NoCpp _ x = pure x
-runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
-runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
- where
- -- LINE pragmas always inserted when locations=True
- 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.
-data ModuleEx = ModuleEx {
- ghcModule :: Located (HsModule GhcPs)
- , ghcAnnotations :: ApiAnns
-}
-
--- | Extract a list of all of a parsed module's comments.
-ghcComments :: ModuleEx -> [Located AnnotationComment]
-ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))
-
-
--- | The error handler invoked when GHC parsing has failed.
-ghcFailOpParseModuleEx :: String
- -> FilePath
- -> String
- -> (SrcSpan, ErrUtils.MsgDoc)
- -> IO (Either ParseError ModuleEx)
-ghcFailOpParseModuleEx ppstr file str (loc, err) = do
- let pe = case loc of
- RealSrcSpan r -> context (srcSpanStartLine r) ppstr
- _ -> ""
- msg = Outputable.showSDoc baseDynFlags err
- pure $ Left $ ParseError loc msg pe
-
--- GHC extensions to enable/disable given HSE parse flags.
-ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
-ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)
-
--- GHC fixities given HSE parse flags.
-ghcFixitiesFromParseFlags :: ParseFlags -> [(String, 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 GHC annotations and module tree. It
--- is assumed the incoming parse module has not been adjusted to
--- account for operator fixities (it uses the HLint default fixities).
-createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
-createModuleEx anns ast =
- ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns
-
--- | 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 $ do
- str <- case str of
- Just x -> pure x
- Nothing | file == "-" -> getContentsUTF8
- | otherwise -> readFileUTF8' file
- str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130
- ppstr <- runCpp (cppFlags flags) file str
- let enableDisableExts = ghcExtensionsFromParseFlags flags
- dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr
- case dynFlags of
- Right ghcFlags -> do
- ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags
- case fileToModule file ppstr ghcFlags of
- POk s a -> do
- let errs = bagToList . snd $ getMessages s ghcFlags
- if not $ null errs then
- handleParseFailure ghcFlags ppstr file str errs
- else do
- let anns =
- ( Map.fromListWith (++) $ annotations s
- , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)
- )
- let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
- pure $ Right (ModuleEx (applyFixities fixes a) anns)
- PFailed s ->
- handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags
- Left msg -> do
- -- Parsing GHC flags from dynamic pragmas in the source
- -- has failed. When this happens, it's reported by
- -- exception. It's impossible or at least fiddly getting a
- -- location so we skip that for now. Synthesize a parse
- -- error.
- let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)
- pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)
- where
- handleParseFailure ghcFlags ppstr file str errs =
- let errMsg = head errs
- loc = errMsgSpan errMsg
- doc = formatErrDoc ghcFlags (errMsgDoc 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) [" "," ","> "," "," "]
diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
--- a/src/Hint/Bracket.hs
+++ b/src/Hint/Bracket.hs
@@ -41,7 +41,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) @NoRefactor
-issue969 = (Just \x -> x || x) *> Just True @NoRefactor
+issue969 = (Just \x -> x || x) *> Just True
-- type bracket reduction
foo :: (Int -> Int) -> Int
@@ -58,12 +58,12 @@
-- dollar reduction tests
no = groupFsts . sortFst $ mr
-yes = split "to" $ names --
-yes = white $ keysymbol --
-yes = operator foo $ operator --
+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] -- @NoRefactor: apply-refact bug; see apply-refact #51
+no = f $ [1,2..5] -- f [1,2..5] @NoRefactor: apply-refact bug; see apply-refact #51
-- $/bracket rotation tests
yes = (b $ c d) ++ e -- b (c d) ++ e
@@ -98,10 +98,10 @@
module Hint.Bracket(bracketHint) where
-import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,suggestRemove,Severity(..),toRefactSrcSpan,toSS)
+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS)
import Data.Data
import Data.List.Extra
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Refact.Types
import GHC.Hs
@@ -183,7 +183,7 @@
-- 'x' actually need bracketing in this context?
f (Just (i, o, gen)) v@(remParens' -> Just x)
| not $ needBracket i o x, not $ isPartialAtom x =
- rawIdea Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x
+ rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x
where
typ = findType (unLoc v)
r = Replace typ (toSS v) [("x", toSS x)] "x"
@@ -207,7 +207,7 @@
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" loc
+ [rawIdea Suggestion "Redundant bracket" l
(showSDocUnsafe $ ppr_fld o) -- Note this custom printer!
(Just (showSDocUnsafe $ ppr_fld r))
[]
@@ -230,7 +230,7 @@
dollar :: LHsExpr GhcPs -> [Idea]
dollar = concatMap f . universe
where
- f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d
+ f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | o@(L _ (OpApp _ a d b)) <- [x], isDol d
, let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs
, not $ needBracket 0 y a
, not $ needBracket 1 y b
@@ -245,7 +245,7 @@
, let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))
, let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]
++ -- Special case of (v1 . v2) <$> v3
- [ suggest "Redundant bracket" x y [r]
+ [ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar}
| L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>"
, let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs
, let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"]
diff --git a/src/Hint/Duplicate.hs b/src/Hint/Duplicate.hs
--- a/src/Hint/Duplicate.hs
+++ b/src/Hint/Duplicate.hs
@@ -24,11 +24,12 @@
import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN,Severity(Suggestion,Warning))
import Data.Data
-import Data.Generics.Uniplate.Operations
+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 SrcLoc
@@ -36,6 +37,7 @@
import Outputable
import Bag
import GHC.Util
+import Language.Haskell.GhclibParserEx.GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
@@ -94,19 +96,23 @@
duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs
where
f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]])
- f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs
+ 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 -> [(pos, val)] -> (Dupe pos val, [(pos, pos, [val])])
+ g :: Map.Map pos Int -> Dupe pos val -> NE.NonEmpty (pos, val) -> (Dupe pos val, [(pos, pos, [val])])
g pos d xs = (d2, res)
where
res = [(p,pme,take mx vs) | i >= threshold
,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos
,mx >= threshold]
- vs = map snd xs
+ vs = NE.toList $ snd <$> xs
(p,i) = find vs d
- pme = fst $ head xs
+ pme = fst $ NE.head xs
d2 = add pme vs d
+
+ onlyAtLeast n = mapMaybe $ \l -> case l of
+ x:xs | length l >= n -> Just (x NE.:| xs)
+ _ -> Nothing
overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs)
overlaps (x:xs) = x : overlaps xs
diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs
--- a/src/Hint/Extensions.hs
+++ b/src/Hint/Extensions.hs
@@ -138,6 +138,16 @@
main = "test"
{-# LANGUAGE OverloadedStrings #-} \
main = id --
+{-# 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 #-} \
@@ -215,9 +225,8 @@
import Hint.Type(ModuHint, rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule)
import Extension
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Control.Monad.Extra
-import Data.Char
import Data.Maybe
import Data.List.Extra
import Data.Data
@@ -379,10 +388,8 @@
(TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs])
_ -> False
- isOp :: LIdP GhcPs -> Bool
- isOp name = case rdrNameStr name of
- (c:_) -> not $ isAlpha c || c == '_'
- _ -> False
+ isOp (L _ name) = isSymbolRdrName name
+
used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot
used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate
used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving
@@ -422,6 +429,23 @@
used LambdaCase = hasS isLCase
used TupleSections = hasS isTupleSection
used OverloadedStrings = hasS isString
+used OverloadedLists = hasS isListExpr ||^ hasS isListPat
+ where
+ isListExpr :: HsExpr GhcPs -> Bool
+ isListExpr ExplicitList{} = True
+ isListExpr ArithSeq{} = True
+ isListExpr _ = False
+
+ isListPat :: Pat GhcPs -> Bool
+ isListPat ListPat{} = True
+ isListPat _ = False
+
+used OverloadedLabels = hasS isLabel
+ where
+ isLabel :: HsExpr GhcPs -> Bool
+ isLabel HsOverLabel{} = True
+ isLabel _ = False
+
used Arrows = hasS isProc
used TransformListComp = hasS isTransStmt
used MagicHash = hasS f ||^ hasS isPrimLiteral
diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs
--- a/src/Hint/Import.hs
+++ b/src/Hint/Import.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, RecordWildCards #-}
+{-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-}
{-
Reduce the number of import declarations.
Two import declarations can be combined if:
@@ -28,31 +28,27 @@
import qualified A; import A
import B; import A; import A -- import A
import A hiding(Foo); import A hiding(Bar)
-import List -- import Data.List @NoRefactor: apply-refact bug
-import qualified List -- import qualified Data.List as List @NoRefactor
-import Char(foo) -- import Data.Char(foo) @NoRefactor
-import IO(foo)
-import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) @NoRefactor
+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,toSS,rawIdea,rawIdeaN)
+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea)
import Refact.Types hiding (ModuleName)
import qualified Refact.Types as R
import Data.Tuple.Extra
import Data.List.Extra
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Control.Applicative
import Prelude
import FastString
import BasicTypes
-import RdrName
-import Module
import GHC.Hs
import SrcLoc
@@ -69,10 +65,7 @@
, let n = unLoc $ ideclName i'
, let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) ++
-- Ideas for removing redundant 'as' clauses.
- concatMap stripRedundantAlias ms ++
- -- Ideas for replacing deprecated imports by their preferred
- -- equivalents.
- concatMap preferHierarchicalImports ms
+ concatMap stripRedundantAlias ms
reduceImports :: [LImportDecl GhcPs] -> [Idea]
reduceImports [] = []
@@ -86,7 +79,9 @@
simplify [] = Nothing
simplify (x : xs) = case simplifyHead x xs of
Nothing -> first (x:) <$> simplify xs
- Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs
+ Just (xs, rs) ->
+ let deletions = filter (\case Delete{} -> True; _ -> False) rs
+ in Just $ maybe (xs, rs) (second (++ deletions)) $ simplify xs
simplifyHead :: LImportDecl GhcPs
-> [LImportDecl GhcPs]
@@ -99,7 +94,7 @@
combine :: LImportDecl GhcPs
-> LImportDecl GhcPs
-> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])
-combine x@(L _ x') y@(L _ y')
+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 (toSS y)])
-- Both (un/)qualified, common 'as', different names : Merge the
@@ -107,7 +102,7 @@
| qual, as
, Just (False, xs) <- ideclHiding x'
, Just (False, ys) <- ideclHiding y' =
- let newImp = noLoc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}
+ let newImp = L loc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}
in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp))
, Delete Import (toSS y)])
-- Both (un/qualified), common 'as', one has names the other doesn't
@@ -140,51 +135,3 @@
| Just (unLoc ideclName) == fmap unLoc ideclAs =
[suggest "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]]
stripRedundantAlias _ = []
-
-preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]
-preferHierarchicalImports x@(L loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing})
- -- Suggest 'import IO' be rewritten 'import System.IO, import
- -- System.IO.Error, import Control.Exception(bracket, bracket_)'.
- | n == mkModuleName "IO" && isNothing (ideclHiding i) =
- [rawIdeaN Suggestion "Use hierarchical imports" loc
- (trimStart $ unsafePrettyPrint i) (
- Just $ unlines $ map (trimStart . unsafePrettyPrint)
- [ f "System.IO" Nothing, f "System.IO.Error" Nothing
- , f "Control.Exception" $ Just (False, noLoc [mkLIE x | x <- ["bracket","bracket_"]])]) []]
- -- Suggest that a module import like 'Monad' should be rewritten with
- -- its hiearchical equivalent e.g. 'Control.Monad'.
- | Just y <- lookup (moduleNameString n) newNames =
- let newModuleName = y ++ "." ++ moduleNameString n
- r = [Replace R.ModuleName (toSS x) [] newModuleName] in
- [suggest "Use hierarchical imports"
- x (noLoc (desugarQual i){ideclName=noLoc (mkModuleName newModuleName)} :: LImportDecl GhcPs) r]
- where
- -- Substitute a new module name.
- f a b = (desugarQual i){ideclName=noLoc (mkModuleName a), ideclHiding=b}
- -- Wrap a literal name into an 'IE' (import/export) value.
- mkLIE :: String -> LIE GhcPs
- mkLIE n = noLoc $ IEVar noExtField (noLoc (IEName (noLoc (mkVarUnqual (fsLit n)))))
- -- Rewrite 'import qualified X' as 'import qualified X as X'.
- desugarQual :: ImportDecl GhcPs -> ImportDecl GhcPs
- desugarQual i
- | ideclQualified i /= NotQualified && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}
- | otherwise = i
-
-preferHierarchicalImports _ = []
-
-newNames :: [(String, String)]
-newNames = let (*) = flip (,) in
- ["Control" * "Monad"
- ,"Data" * "Char"
- ,"Data" * "List"
- ,"Data" * "Maybe"
- ,"Data" * "Ratio"
- ,"System" * "Directory"
-
- -- Special, see bug https://code.google.com/archive/p/ndmitchell/issues/393
- -- ,"System" * "IO"
-
- -- Do not encourage use of old-locale/old-time over haskell98
- -- ,"System" * "Locale"
- -- ,"System" * "Time"
- ]
diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs
--- a/src/Hint/Lambda.hs
+++ b/src/Hint/Lambda.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ViewPatterns, PatternGuards #-}
+{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}
{-
Concept:
@@ -22,7 +22,9 @@
f a = \x -> x + x -- f a x = x + x
f a = \a -> a + a -- f _ a = a + a
-f (Just a) = \a -> a + a -- f (Just _) a = a + a @NoRefactor
+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
@@ -84,7 +86,7 @@
yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor
yes = blah (\ x -> (y, x, z+x))
tmp = map (\ x -> runST $ action x)
-yes = map (\f -> dataDir f) dataFiles -- (dataDir ) @NoRefactor
+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)
@@ -100,9 +102,10 @@
import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)
import Util
import Data.List.Extra
+import Data.Set (Set)
import qualified Data.Set as Set
import Refact.Types hiding (RType(Match))
-import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi)
+import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi)
import BasicTypes
import GHC.Hs
@@ -125,18 +128,18 @@
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl
o@(L _ (ValD _
- origBind@FunBind {fun_id = L loc1 _, fun_matches =
+ 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))]}}))
| L _ (EmptyLocalBinds noExtField) <- bind
, isLambda $ fromParen origBody
, null (universeBi pats :: [HsExpr GhcPs])
- = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) s1 t1]]
+ = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) subts template]]
| length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind
= [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2)
[ -- Disabled, see apply-refact #3
- -- Replace Decl (toSS $ reform' pats origBody) s2 t2]]
- ]]
+ ]
+ ]
where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform ps b = L loc $ ValD noExtField $
origBind
@@ -149,12 +152,9 @@
(finalpats, body) = fromLambda . lambda pats $ origBody
(pats2, bod2) = etaReduce pats origBody
- template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody
- subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)
- s1 = subts finalpats body
- --s2 = subts pats2 bod2
- t1 = template finalpats
- --t2 = template pats2 bod2
+ (origPats, subtsVars) = mkOrigPats (Just (rdrNameStr funName)) finalpats
+ subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS finalpats)
+ template = unsafePrettyPrint (reform origPats varBody)
lambdaDecl _ = []
@@ -186,10 +186,15 @@
, not $ any isQuasiQuote $ universe res
, not $ "runST" `Set.member` Set.map occNameString (freeVars o)
, let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")
- = [(if isVar res then warn else suggest) name o res (refact $ toSS o)]
+ -- 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, res) of
+ (Just p@(L _ (HsPar _ (L _ HsLam{}))), L _ HsPar{}) -> p
+ _ -> o
+ = [(if isVar res then warn else suggest) name from res (refact $ toSS 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?
@@ -197,10 +202,9 @@
[suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]
where
(pats, body) = fromLambda o
-
- template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody
-
- subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)
+ (oPats, subtsVars) = mkOrigPats Nothing pats
+ subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS 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)) =
@@ -268,7 +272,31 @@
f bad x = x
fromLambda x = ([], x)
--- | Replaces all non-wildcard patterns with a variable pattern with the given identifier.
-munge :: Char -> LPat GhcPs -> LPat GhcPs
-munge ident p@(L _ (WildPat _)) = p
-munge ident (L ploc p) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))
+-- | 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 is ['a'..'z'],
+-- excluding variables that occur in the function name or patterns with wildcards. For example, given
+-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are removed.
+mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])
+mkOrigPats funName pats = (zipWith munge subtsVars pats', subtsVars)
+ where
+ (Set.unions -> used, pats') = unzip (map f pats)
+
+ -- Remove variables that occur in the function name or patterns with wildcards
+ subtsVars = filter (\c -> c `Set.notMember` used && Just [c] /= funName) ['a'..'z']
+
+ -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))
+ f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
+ f p
+ | any isWildPat (universe p) =
+ let used = Set.fromList [c | (L _ (VarPat _ (rdrNameStr -> [c]))) <- 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 :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
+ munge _ (True, p) = p
+ munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))
diff --git a/src/Hint/List.hs b/src/Hint/List.hs
--- a/src/Hint/List.hs
+++ b/src/Hint/List.hs
@@ -13,7 +13,7 @@
no = "x" ++ xs
no = [x] ++ xs ++ ys
no = xs ++ [x] ++ ys
-yes = [if a then b else c] ++ xs -- (if a then b else c) : xs @NoRefactor: hlint bug, missing brackets in refactoring template
+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
@@ -33,18 +33,19 @@
{-# LANGUAGE MonadComprehensions #-}\
foo = [x | False, x <- [1 .. 10]] -- []
foo = [_ | x <- _, let _ = A{x}]
+issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []]
-}
module Hint.List(listHint) where
import Control.Applicative
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Maybe
import Prelude
-import Hint.Type(DeclHint,Idea,suggest,toRefactSrcSpan,toSS)
+import Hint.Type(DeclHint,Idea,suggest,ignore,toRefactSrcSpan,toSS)
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
@@ -84,6 +85,7 @@
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)))) =
@@ -230,17 +232,17 @@
useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)
useCons False (view -> App2 op x y) | varToStr op == "++"
- , Just (x2, build) <- f x
- , not $ isAppend y =
- Just (gen (build x2) y
- , [("x", toSS x2), ("xs", toSS y)]
- , unsafePrettyPrint $ gen (build $ strToVar "x") (strToVar "xs")
+ , Just (newX, tplX, spanX) <- f x
+ , not $ isAppend y =
+ Just (gen newX y
+ , [("x", spanX), ("xs", toSS y)]
+ , unsafePrettyPrint $ gen tplX (strToVar "xs")
)
where
- f :: LHsExpr GhcPs ->
- Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
- f (L _ (ExplicitList _ _ [x]))=
- Just (x, \v -> if isApp x then v else paren v)
+ f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)
+ f (L _ (ExplicitList _ _ [x]))
+ | isAtom x || isApp x = Just (x, strToVar "x", toSS x)
+ | otherwise = Just (addParen x, addParen (strToVar "x"), toSS x)
f _ = Nothing
gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
@@ -267,7 +269,7 @@
f x = concatMap g $ childrenBi x
g :: LHsType GhcPs -> [Idea]
- g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)
+ g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x)
rs | not . null $ rs]
where f x = if astEq x typeListChar then typeString else x
rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs
--- a/src/Hint/ListRec.hs
+++ b/src/Hint/ListRec.hs
@@ -33,7 +33,7 @@
import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS)
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Maybe
import Data.Either.Extra
diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
--- a/src/Hint/Match.hs
+++ b/src/Hint/Match.hs
@@ -49,7 +49,7 @@
import Data.Tuple.Extra
import Data.Maybe
import Config.Type
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Bag
import GHC.Hs
@@ -201,6 +201,7 @@
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
diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs
--- a/src/Hint/Monad.hs
+++ b/src/Hint/Monad.hs
@@ -75,7 +75,7 @@
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util
-import Data.Generics.Uniplate.Data
+import Data.Generics.Uniplate.DataOnly
import Data.Tuple.Extra
import Data.Maybe
import Data.List.Extra
diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs
--- a/src/Hint/Naming.hs
+++ b/src/Hint/Naming.hs
@@ -41,13 +41,12 @@
module Hint.Naming(namingHint) where
-import Hint.Type (Idea,DeclHint,suggest,toSS,ghcModule)
-import Data.Generics.Uniplate.Operations
+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 Refact.Types hiding (RType(Match))
import qualified Data.Set as Set
import BasicTypes
@@ -70,7 +69,8 @@
[ suggest "Use camelCase"
(shorten originalDecl)
(shorten replacedDecl)
- [Replace Bind (toSS originalDecl) [] (unsafePrettyPrint replacedDecl)]
+ [ -- https://github.com/mpickering/apply-refact/issues/39
+ ]
| not $ null suggestedNames
]
where
@@ -111,6 +111,7 @@
concatMap (map unsafePrettyPrint . getConNames . unLoc) cons
getConstructorNames _ = []
+isSym :: String -> Bool
isSym (x:_) = not $ isAlpha x || x `elem` "_'"
isSym _ = False
diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs
--- a/src/Hint/Pattern.hs
+++ b/src/Hint/Pattern.hs
@@ -26,17 +26,17 @@
foo = case v of z -> z
foo = case v of _ | False -> x
foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.
-foo = case v of !True -> x -- True @NoRefactor: apply-refact requires BangPatterns pragma
+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) @NoRefactor
+{-# 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 @NoRefactor
+{-# 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
@@ -51,6 +51,7 @@
{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ())
foo x@_ = x -- x
foo x@Foo = x
+otherwise = True
-}
@@ -58,7 +59,7 @@
module Hint.Pattern(patternHint) where
import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn)
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.Function
import Data.List.Extra
import Data.Tuple
diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs
--- a/src/Hint/Pragma.hs
+++ b/src/Hint/Pragma.hs
@@ -18,9 +18,9 @@
{-# 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 #-} @NoRefactor: the two pragmas are switched in the refactoring output
+{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-}
{-# OPTIONS_GHC -cpp #-} \
-{-# LANGUAGE CPP, Text #-} -- @NoRefactor
+{-# LANGUAGE CPP, Text #-} --
{-# LANGUAGE RebindableSyntax #-} \
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-} \
@@ -72,7 +72,7 @@
-> Refactoring R.SrcSpan
mkRefact old (maybe "" comment -> new) ns =
let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns
- in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (new : ns')))
+ in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new)))
data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)
| MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)
diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs
--- a/src/Hint/Restrict.hs
+++ b/src/Hint/Restrict.hs
@@ -24,7 +24,7 @@
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea)
import Config.Type
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -42,6 +42,7 @@
import Module
import SrcLoc
import OccName
+import Language.Haskell.GhclibParserEx.GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util
diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs
--- a/src/Hint/Smell.hs
+++ b/src/Hint/Smell.hs
@@ -81,7 +81,7 @@
import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn)
import Config.Type
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import qualified Data.Map as Map
diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs
--- a/src/Hint/Type.hs
+++ b/src/Hint/Type.hs
@@ -6,7 +6,7 @@
import Data.Semigroup
import Config.Type
-import HSE.All as Export
+import GHC.All as Export
import Idea as Export
import Prelude
import Refact as Export
diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs
--- a/src/Hint/Unsafe.hs
+++ b/src/Hint/Unsafe.hs
@@ -21,7 +21,7 @@
import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS)
import Data.List.Extra
import Refact.Types hiding(Match)
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
import GHC.Hs
import OccName
diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs
--- a/src/Language/Haskell/HLint.hs
+++ b/src/Language/Haskell/HLint.hs
@@ -38,7 +38,7 @@
import HLint
import Fixity
import FastString
-import HSE.All
+import GHC.All
import Hint.All hiding (resolveHints)
import qualified Hint.All as H
import SrcLoc
diff --git a/src/Refact.hs b/src/Refact.hs
--- a/src/Refact.hs
+++ b/src/Refact.hs
@@ -10,6 +10,7 @@
import Control.Monad
import Data.Maybe
import Data.Version.Extra
+import GHC.LanguageExtensions.Type
import System.Directory.Extra
import System.Exit
import System.IO.Extra
@@ -43,7 +44,7 @@
case mexc of
Just exc -> do
ver <- readVersion . tail <$> readProcess exc ["--version"] ""
- pure $ if versionBranch ver >= [0,1,0,0]
+ pure $ if versionBranch ver >= [0,7,0,0]
then Right exc
else Left "Your version of refactor is too old, please upgrade to the latest version"
Nothing -> pure $ Left $ unlines
@@ -53,9 +54,11 @@
, ""
]
-runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode
-runRefactoring rpath fin hints opts = do
+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]]
(_, _, _, phand) <- createProcess $ proc rpath args
try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())
hSetBuffering stdout LineBuffering
diff --git a/src/Test/All.hs b/src/Test/All.hs
--- a/src/Test/All.hs
+++ b/src/Test/All.hs
@@ -39,7 +39,7 @@
xs <- liftIO $ getDirectoryContents dataDir
pure [dataDir x | x <- xs, takeExtension x `elem` [".yml",".yaml"]]
testFiles <- liftIO $ forM testFiles $ \file -> do
- hints <- readFilesConfig [(file, Nothing)]
+ 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 ""
diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
--- a/src/Test/Annotations.hs
+++ b/src/Test/Annotations.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, RecordWildCards, ViewPatterns #-}
+{-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-}
-- | Check the annotations within source and hint files.
module Test.Annotations(testAnnotations) where
@@ -13,16 +13,16 @@
import Data.List.Extra
import Data.Maybe
import Data.Tuple.Extra
-import Data.Yaml
import System.Exit
import System.FilePath
import System.IO.Extra
-import HSE.All
+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
@@ -33,6 +33,21 @@
import 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
@@ -161,7 +176,7 @@
x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y
writeFile tempInp inp
writeFile tempHints (show refacts)
- exitCode <- runRefactoring rpath tempInp tempHints "--inplace"
+ exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace"
refactored <- readFile tempInp
pure $ case exitCode of
ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]
diff --git a/src/Util.hs b/src/Util.hs
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -12,7 +12,7 @@
import System.IO.Unsafe
import Unsafe.Coerce
import Data.Data
-import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.DataOnly
---------------------------------------------------------------------
@@ -56,11 +56,11 @@
---------------------------------------------------------------------
-- DATA.GENERICS.UNIPLATE.OPERATIONS
-universeParent :: Uniplate a => a -> [(Maybe a, a)]
+universeParent :: Data a => a -> [(Maybe a, a)]
universeParent x = (Nothing,x) : f x
where
- f :: Uniplate a => a -> [(Maybe a, a)]
+ f :: Data a => a -> [(Maybe a, a)]
f x = concat [(Just x, y) : f y | y <- children x]
-universeParentBi :: Biplate a b => a -> [(Maybe b, b)]
+universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi = concatMap universeParent . childrenBi