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