packages feed

hlint 2.2.4 → 2.2.5

raw patch · 26 files changed

+835/−68 lines, 26 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for HLint (* = breaking change) +2.2.5, released 2019-12-06+    #803, allow newer ghc-lib-8.8.1+    #792, note that reverse/sort changes sort stability+    #793, don't incorrectly suggest foldr 2.2.4, released 2019-11-02     Allow haskell-src-exts-1.22     #788, give less redundant context on unused variable capture
README.md view
@@ -177,7 +177,7 @@  ### Which hints are used? -HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. If you pass any `--with` hint you will need to explicitly add any `--hint` flags required.+HLint uses the `hlint.yaml` file it ships with by default (containing things like the `concatMap` hint above), along with the first `.hlint.yaml` file it finds in the current directory or any parent thereof. To include other hints, pass `--hint=filename.yaml`. If you pass any `--with` hint you will need to explicitly add any `--hint` flags required.  ### Why do I sometimes get a "Note" with my hint?
data/hlint.yaml view
@@ -98,11 +98,11 @@     - warn: {lhs: last (sort x), rhs: maximum x}     - warn: {lhs: head (sortBy f x), rhs: minimumBy f x, side: isCompare f}     - warn: {lhs: last (sortBy f x), rhs: maximumBy f x, side: isCompare f}-    - warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f}+    - warn: {lhs: reverse (sortBy f x), rhs: sortBy (flip f) x, name: Avoid reverse, side: isCompare f, note: Stabilizes sort order}     - warn: {lhs: sortBy (comparing (flip f)), rhs: sortOn (Down . f)}     - warn: {lhs: sortBy (comparing f), rhs: sortOn f}-    - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse}-    - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse}+    - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order}+    - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order}     - hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip}     - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on}
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.2.4+version:            2.2.5 license:            BSD3 license-file:       LICENSE category:           Development@@ -74,7 +74,7 @@           ghc-boot-th     else         build-depends:-          ghc-lib-parser == 8.8.1+          ghc-lib-parser == 8.8.1.*      if flag(gpl)         build-depends: hscolour >= 1.21@@ -124,6 +124,9 @@         GHC.Util.Language.Haskell.GHC.ExactPrint.Types         GHC.Util.Refact.Utils         GHC.Util.Refact.Fixity+        GHC.Util.RdrName+        GHC.Util.Scope+        GHC.Util.Unify          HSE.All         HSE.Match
src/Apply.hs view
@@ -56,7 +56,8 @@     , let classifiers = cls ++ mapMaybe readPragma (universeBi (hseModule m)) ++ concatMap readComment (ghcComments m)     , seq (length classifiers) True -- to force any errors from readPragma or readComment     , let decHints = hintDecl hints settings nm m -- partially apply-    , let decHints' = hintDecl' hints settings nm m -- partially apply+    , (nm',m') <- mns'+    , let decHints' = hintDecl' hints settings nm' m' -- partially apply     , let order n = map (\i -> i{ideaModule= f $ moduleName (hseModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn ideaSpan     , let merge = mergeBy (comparing ideaSpan)] ++     [map (classify cls) (hintModules hints settings mns)]@@ -64,6 +65,7 @@         f = nubOrd . filter (/= "")         cls = [x | SettingClassify x <- settings]         mns = map (\x -> (scopeCreate (hseModule x), x)) ms+        mns' = map (\x -> (scopeCreate' (GHC.unLoc $ ghcModule x), x)) ms         hints = (if length ms <= 1 then noModules else id) hints_         noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}
src/Config/Haskell.hs view
@@ -15,6 +15,9 @@ import Config.Type import Util import Prelude++import qualified HsSyn as GHC+import qualified BasicTypes as GHC import GHC.Util import SrcLoc as GHC import ApiAnnotation@@ -48,7 +51,11 @@ readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])     | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =         let (a,b) = readSide $ childrenBi bind in-        [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b]+        let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed in+        [SettingMatchExp $+         HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b+        -- Todo : Replace these with "proper" GHC expressions.+         (wrap mempty) (wrap unit) (wrap unit) Nothing]     | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]     where         names = filter (not . null) $ getNames pats bod
src/Config/Type.hs view
@@ -10,6 +10,8 @@ import Data.List.Extra import Prelude +import qualified HsSyn+import GHC.Util  getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore@@ -85,8 +87,10 @@     }     deriving Show ++ -- | A @LHS ==> RHS@ style hint rule.-data HintRule {- PUBLIC -} = HintRule+data HintRule = HintRule     {hintRuleSeverity :: Severity -- ^ Default severity for the hint.     ,hintRuleName :: String -- ^ Name for the hint.     ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.@@ -94,6 +98,11 @@     ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS     ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.     ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.+    -- We wrap these GHC elements in 'W' in order that we may derive 'Show'.+    ,hintRuleGhcScope :: W Scope' -- ^ Module scope in which the hint operates (GHC parse tree).+    ,hintRuleGhcLHS :: W (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree).+    ,hintRuleGhcRHS :: W (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree).+    ,hintRuleGhcSide :: Maybe (W (HsSyn.LHsExpr HsSyn.GhcPs))  -- ^ Side condition (GHC parse tree).     }     deriving Show
src/Config/Yaml.hs view
@@ -25,6 +25,12 @@ import Util import Prelude +import qualified Lexer as GHC+import qualified ErrUtils+import qualified Outputable+import qualified HsSyn+import GHC.Util (baseDynFlags, Scope',scopeCreate')+import GHC.Util.W  -- | Read a config file in YAML format. Takes a filename, and optionally the contents. --   Fails if the YAML doesn't parse or isn't valid HLint YAML@@ -52,12 +58,14 @@ data Package = Package     {packageName :: String     ,packageModules :: [ImportDecl S]+    ,packageGhcModules :: [W (HsSyn.LImportDecl HsSyn.GhcPs)]     } deriving Show  data Group = Group     {groupName :: String     ,groupEnabled :: Bool     ,groupImports :: [Either String (ImportDecl S)] -- Left for package imports+    ,groupGhcImports :: [Either String (W (HsSyn.LImportDecl HsSyn.GhcPs))]     ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty     } deriving Show @@ -150,8 +158,18 @@     x <- parseString v     case parser defaultParseMode{extensions=configExtensions} x of         ParseOk x -> return x-        ParseFailed loc s -> parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n  " ++ x+        ParseFailed loc s ->+          parseFail v $ "Failed to parse " ++ s ++ ", when parsing:\n  " ++ x +parseGHC :: (ParseMode -> String -> GHC.ParseResult v) -> Val -> Parser v+parseGHC parser v = do+    x <- parseString v+    case parser defaultParseMode{extensions=configExtensions} x of+        GHC.POk _ x -> return x+        GHC.PFailed _ loc err ->+          let msg = Outputable.showSDoc baseDynFlags $+                ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)+          in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x  --------------------------------------------------------------------- -- YAML TO DATA TYPE@@ -180,6 +198,7 @@ parsePackage v = do     packageName <- parseField "name" v >>= parseString     packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)+    packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap wrap <$> parseGHC parseImportDeclGhcWithMode)     allowFields v ["name","modules"]     return Package{..} @@ -205,6 +224,7 @@     groupName <- parseField "name" v >>= parseString     groupEnabled <- parseFieldOpt "enabled" v >>= maybe (return True) parseBool     groupImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImport)+    groupGhcImports <- parseFieldOpt "imports" v >>= maybe (return []) (parseArray >=> mapM parseImportGHC)     groupRules <- parseFieldOpt "rules" v >>= maybe (return []) parseArray >>= concatMapM parseRule     allowFields v ["name","enabled","imports","rules"]     return Group{..}@@ -214,9 +234,14 @@             case word1 x of                 ("package", x) -> return $ Left x                 _ -> Right <$> parseHSE parseImportDeclWithMode v+        parseImportGHC v = do+            x <- parseString v+            case word1 x of+                 ("package", x) -> return $ Left x+                 _ -> Right . wrap <$> parseGHC parseImportDeclGhcWithMode v  ruleToGroup :: [Either HintRule Classify] -> Group-ruleToGroup = Group "" True []+ruleToGroup = Group "" True [] []  parseRule :: Val -> Parser [Either HintRule Classify] parseRule v = do@@ -228,8 +253,14 @@         hintRuleNotes <- parseFieldOpt "note" v >>= maybe (return []) (fmap (map asNote) . parseArrayString)         hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString         hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode)++        hintRuleGhcLHS <- parseField "lhs" v >>= fmap wrap . parseGHC parseExpGhcWithMode+        hintRuleGhcRHS <- parseField "rhs" v >>= fmap wrap . parseGHC parseExpGhcWithMode+        hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . wrap) . parseGHC parseExpGhcWithMode)+         allowFields v ["lhs","rhs","note","name","side"]-        let hintRuleScope = mempty+        let hintRuleScope = mempty :: Scope+        let hintRuleGhcScope = wrap mempty :: W Scope'         return [Left HintRule{hintRuleSeverity=severity, ..}]      else do         names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString@@ -299,12 +330,15 @@         groups = [x | ConfigGroup x <- configs]         settings = concat [x | ConfigSetting x <- configs]         packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages]+        packageMap' = Map.fromListWith (++) [(packageName, fmap unwrap packageGhcModules) | Package{..} <- packages]         groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]          f Group{..}             | Map.lookup groupName groupMap == Just False = []-            | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope}) SettingClassify) groupRules-            where scope = asScope packageMap groupImports+            | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope,hintRuleGhcScope=scope'}) SettingClassify) groupRules+            where+              scope = asScope packageMap groupImports+              scope'= asScope' packageMap' (map (fmap unwrap) groupGhcImports)  asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []@@ -312,3 +346,10 @@         f (Right x) = [x]         f (Left x) | Just pkg <- Map.lookup x packages = pkg                    | otherwise = error $ "asScope failed to do lookup, " ++ x++asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> W Scope'+asScope' packages xs = W $ scopeCreate' (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)+    where+        f (Right x) = [x]+        f (Left x) | Just pkg <- Map.lookup x packages = pkg+                   | otherwise = error $ "asScope' failed to do lookup, " ++ x
src/GHC/Util.hs view
@@ -13,8 +13,11 @@   , module GHC.Util.SrcLoc   , module GHC.Util.W   , module GHC.Util.DynFlags+  , module GHC.Util.Scope+  , module GHC.Util.RdrName+  , module GHC.Util.Unify -  , parsePragmasIntoDynFlags, parseFileGhcLib+  , parsePragmasIntoDynFlags, parseFileGhcLib, parseExpGhcLib, parseImportGhcLib   ) where  import GHC.Util.View@@ -30,6 +33,9 @@ import GHC.Util.SrcLoc import GHC.Util.W import GHC.Util.DynFlags+import GHC.Util.RdrName+import GHC.Util.Scope+import GHC.Util.Unify  import HsSyn import Lexer@@ -46,6 +52,20 @@ import Data.List.Extra import System.FilePath import Language.Preprocessor.Unlit++parseGhcLib :: P a -> String -> DynFlags -> ParseResult a+parseGhcLib p str flags =+  Lexer.unP p parseState+  where+    location = mkRealSrcLoc (mkFastString "<string>") 1 1+    buffer = stringToStringBuffer str+    parseState = mkPState flags buffer location++parseExpGhcLib :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)+parseExpGhcLib = parseGhcLib Parser.parseExpression++parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs)+parseImportGhcLib = parseGhcLib Parser.parseImport  parseFileGhcLib :: FilePath                 -> String
src/GHC/Util/FreeVars.hs view
@@ -25,7 +25,6 @@ import qualified Data.Set as Set import Prelude - ( ^+ ) :: Set OccName -> Set OccName -> Set OccName ( ^+ ) = Set.union ( ^- ) :: Set OccName -> Set OccName -> Set OccName@@ -34,6 +33,12 @@ -- See [Note : Spack leaks lurking here?] below. data Vars' = Vars'{bound' :: Set OccName, free' :: Set OccName} +-- Useful for debugging.+instance Show Vars' where+  show (Vars' bs fs) = "bound : " +++    show (map occNameString (Set.toList bs)) +++    ", free : " ++ show (map occNameString (Set.toList fs))+ instance Semigroup Vars' where     Vars' x1 x2 <> Vars' y1 y2 = Vars' (x1 ^+ y1) (x2 ^+ y2) @@ -96,8 +101,8 @@ 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 _ (HsLam _ mg)) = free' (allVars' mg) -- Lambda abstraction. Currently always a single match.+  freeVars' (dL -> L _ (HsLamCase _ mg)) = free' (allVars' mg) -- Lambda-case.   freeVars' (dL -> L _ (HsCase _ of_ MG{mg_alts=(dL -> L _ ms)})) = freeVars' of_ ^+ free' (allVars' ms) -- Case expr.   freeVars' (dL -> L _ (HsLet _ binds e)) = inFree' binds e -- Let (rec).   freeVars' (dL -> L _ (HsDo _ ctxt (dL -> L _ stmts))) = free' (allVars' stmts) -- Do block.@@ -214,10 +219,15 @@    allVars' _ = mempty -- New ctor. +instance AllVars' (MatchGroup GhcPs (LHsExpr GhcPs)) where+  allVars' (MG _ _alts@(dL -> L _ alts) _) = inVars' (foldMap (allVars' . m_pats) ms) (allVars' (map m_grhss ms))+    where ms = map unLoc alts+  allVars' _ = mempty -- New ctor.+ instance AllVars' (LMatch GhcPs (LHsExpr GhcPs)) where   allVars' (dL -> L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars' (VarPat noExt name :: Pat GhcPs) <> allVars' pats <> allVars' grhss -- A pattern matching on an argument of a function binding.   allVars' (dL -> L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars' ctxt <> allVars' pats <> allVars' grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.-  allVars' (dL -> L _ (Match _ _ pats grhss)) = allVars' pats <> allVars' grhss -- Everything else.+  allVars' (dL -> L _ (Match _ _ pats grhss)) = inVars' (allVars' pats) (allVars' grhss) -- Everything else.    allVars' _ = mempty -- New ctor. @@ -234,7 +244,7 @@   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' (dL -> L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards    allVars' _ = mempty -- New ctor.
src/GHC/Util/HsExpr.hs view
@@ -2,20 +2,22 @@ {-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TupleSections #-} ---  Keep until 'isDotApp', 'descendApps', 'transformApps' and--- 'allowLeftSection' are used.+--  Keep until 'descendApps', 'transformApps' and 'allowLeftSection'+-- are used. {-# OPTIONS_GHC -Wno-unused-top-binds #-}  module GHC.Util.HsExpr (     noSyntaxExpr'-  , isTag', isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isReturn'-  , dotApp'+  , isTag', isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isLambda', isQuasiQuote', isTypeApp', isWHNF',isReturn'+  , dotApp', dotApps'   , simplifyExp', niceLambda', niceDotApp'   , Brackets'(..)   , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp'   , varToStr', strToVar'   , paren', fromChar'   , replaceBranches'+  , needBracketOld', transformBracketOld', descendBracketOld', reduce', reduce1', fromParen1'+  , hasFieldsDotDot', isFieldPun' ) where  import HsSyn@@ -45,7 +47,6 @@ import Refact.Types hiding (Match) import qualified Refact.Types as R (SrcSpan) ---  noSyntaxExpr' :: SyntaxExpr GhcPs noSyntaxExpr' =@@ -58,6 +59,11 @@ dotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs dotApp' x y = noLoc $ OpApp noExt x (noLoc $ HsVar noExt (noLoc $ mkVarUnqual (fsLit "."))) y +dotApps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs+dotApps' [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"+dotApps' [x] = x+dotApps' (x : xs) = dotApp' x (dotApps' xs)+ -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren' :: LHsExpr GhcPs -> LHsExpr GhcPs paren' x@@ -69,7 +75,7 @@ isTag' (LL _ (HsVar _ (L _ s))) tag = occNameString (rdrNameOcc s) == tag isTag' _ _ = False -isVar',isReturn',isLexeme',isDotApp',isRecUpdate',isRecConstr',isDol',isDot' :: LHsExpr GhcPs -> Bool+isVar',isReturn',isLexeme',isLambda',isQuasiQuote',isTypeApp',isDotApp',isRecUpdate',isRecConstr',isDol',isDot' :: LHsExpr GhcPs -> Bool isPar' (LL _ HsPar{}) = True; isPar' _ = False isVar' (LL _ HsVar{}) = True; isVar' _ = False isDot' x = isTag' x "."@@ -79,14 +85,39 @@ 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+isTypeApp' (LL _ HsAppType{}) = True; isTypeApp' _ = False+isLambda' (LL _ HsLam{}) = True; isLambda' _ = False+isQuasiQuote' (LL _ (HsSpliceE _ HsQuasiQuote{})) = True; isQuasiQuote' _ = False ---+isWHNF' :: LHsExpr GhcPs -> Bool+isWHNF' (LL _ (HsVar _ (L _ x))) = isRdrDataCon x+isWHNF' (LL _ (HsLit _ x)) = case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True+isWHNF' (LL _ HsLam{}) = True+isWHNF' (LL _ ExplicitTuple{}) = True+isWHNF' (LL _ ExplicitList{}) = True+isWHNF' (LL _ (HsPar _ x)) = isWHNF' x+isWHNF' (LL _ (ExprWithTySig _ x _)) = isWHNF' x+-- Other (unknown) constructors may have bang patterns in them, so+-- approximate.+isWHNF' (LL _ (HsApp _ (LL _ (HsVar _ (L _ x))) _))| occNameString (rdrNameOcc x) `elem` ["Just", "Left", "Right"] = True+isWHNF' _ = False ++-- Contains a '..' as in 'Foo{..}'+hasFieldsDotDot' :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool+hasFieldsDotDot' HsRecFields {rec_dotdot=Just _} = True+hasFieldsDotDot' _ = False++-- Field is punned e.g. '{foo}'.+isFieldPun' :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool+isFieldPun' (LL _ HsRecField {hsRecPun=True}) = True+isFieldPun' _ = False++ universeParentExp' :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)] universeParentExp' xs = concat [(Nothing, x) : f x | x <- childrenBi xs]     where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p] ---  apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y)@@ -141,7 +172,6 @@ appsBracket' = foldl1 mkApp   where mkApp x y = rebracket1' (noLoc $ HsApp noExt x y) ---  varToStr' :: LHsExpr GhcPs -> String varToStr' (LL _ (HsVar _ (L _ n)))@@ -154,7 +184,6 @@ 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)'.@@ -172,12 +201,12 @@     _ -> e simplifyExp' e = e --- ($) . b ==> b+-- Rewrite '($) . b' as '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.@@ -228,13 +257,11 @@       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 ---  -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?).@@ -256,3 +283,52 @@     g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"  replaceBranches' x = ([], \[] -> x)+++-- Like needBracket, but with a special case for 'a . b . b', which was+-- removed from haskell-src-exts-util-0.2.2.+needBracketOld' :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool+needBracketOld' i parent child+  | isDotApp' parent, isDotApp' child, i == 2 = False+  | otherwise = needBracket' i parent child++transformBracketOld' :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs+transformBracketOld' op = snd . g+  where+    g = f . descendBracketOld' g+    f x = maybe (False, x) (True, ) (op x)++-- Descend, and if something changes then add/remove brackets+-- appropriately+descendBracketOld' :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs+descendBracketOld' op x = descendIndex' g x+  where+    g i y = if a then f i b else b+      where (a, b) = op y++    f i (LL _ (HsPar _ y)) | not $ needBracketOld' i x y = y+    f i y                  | needBracketOld' i x y = addParen' y+    f _ y                  = y++reduce' :: LHsExpr GhcPs -> LHsExpr GhcPs+reduce' = fromParen' . transform reduce1'++reduce1' :: LHsExpr GhcPs -> LHsExpr GhcPs+reduce1' (LL loc (HsApp _ len (LL _ (HsLit _ (HsString _ xs)))))+  | varToStr' len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))+  where n = fromIntegral $ length (unpackFS xs)+reduce1' (LL loc (HsApp _ len (LL _ (ExplicitList _ _ xs))))+  | varToStr' len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))+  where n = fromIntegral $ length xs+reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr' op == "==" = strToVar' (show (eqLoc' x y))+reduce1' (view' -> App2' op (LL _ (HsLit _ (HsInt _ x))) (LL _ (HsLit _ (HsInt _ y)))) | varToStr' op == ">=" = strToVar' $ show (x >= y)+reduce1' (view' -> App2' op x y)+    | varToStr' op == "&&" && varToStr' x == "True"  = y+    | varToStr' op == "&&" && varToStr' x == "False" = x+reduce1' (LL _ (HsPar _ x)) | isAtom' x = x+reduce1' x = x+++fromParen1' :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen1' (LL _ (HsPar _ x)) = x+fromParen1' x = x
src/GHC/Util/Module.hs view
@@ -1,5 +1,5 @@ -module GHC.Util.Module (modName) where+module GHC.Util.Module (modName, fromModuleName') where  import HsSyn import Module@@ -9,3 +9,7 @@ modName (LL _ HsModule {hsmodName=Nothing}) = "Main" modName (LL _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n modName _ = "" -- {-# COMPLETE LL #-}++fromModuleName' :: Located ModuleName -> String+fromModuleName' (LL _ n) = moduleNameString n+fromModuleName' _ = "" -- {# COMPLETE LL #}
+ src/GHC/Util/RdrName.hs view
@@ -0,0 +1,24 @@+module GHC.Util.RdrName (isSpecial', unqual', rdrNameStr',fromQual') where++import SrcLoc+import Name+import RdrName++rdrNameStr' :: Located RdrName -> String+rdrNameStr' = occNameString . rdrNameOcc . unLoc++-- Builtin type or data constructors.+isSpecial' :: Located RdrName -> Bool+isSpecial' (L _ (Exact n)) = isDataConName n || isTyConName n+isSpecial' _ = False++-- Coerce qualified names to unqualified (by discarding the+-- qualifier).+unqual' :: Located RdrName -> Located RdrName+unqual' (L loc (Qual _ n)) = cL loc $ mkRdrUnqual n+unqual' x = x++fromQual' :: Located RdrName -> Maybe OccName+fromQual' (L _ (Qual _ x)) = Just x+fromQual' (L _ (Unqual x)) = Just x+fromQual' _ = Nothing
src/GHC/Util/Refact/Fixity.hs view
@@ -26,7 +26,7 @@  -- | 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 :: (Data a) => Anns -> [(String, Fixity)] -> a -> (Anns, a) 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')
+ src/GHC/Util/Scope.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.Scope (+   Scope'+  ,scopeCreate',scopeImports',scopeMatch',scopeMove'+) where++import HsSyn+import SrcLoc+import BasicTypes+import Module+import FastString+import RdrName+import OccName++import GHC.Util.Module+import GHC.Util.RdrName+import Outputable++import Data.List+import Data.Maybe++-- A scope is a list of import declarations.+newtype Scope' = Scope' [LImportDecl GhcPs]+               deriving (Outputable, Monoid, Semigroup)++-- Create a 'Scope' from a module's import declarations.+scopeCreate' :: HsModule GhcPs -> Scope'+scopeCreate' xs = Scope' $ [prelude | not $ any isPrelude res] ++ res+  where+    -- Package qualifier of an import declaration.+    pkg :: LImportDecl GhcPs -> Maybe StringLiteral+    pkg (LL _ x) = ideclPkgQual x+    pkg _  = Nothing -- {-# COMPLETE LL #-}++    -- The import declaraions contained by the module 'xs'.+    res :: [LImportDecl GhcPs]+    res = [x | x <- hsmodImports xs , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint"))]++    -- Mock up an import declaraion corresponding to 'import Prelude'.+    prelude :: LImportDecl GhcPs+    prelude = noLoc $ simpleImportDecl (mkModuleName "Prelude")++    -- Predicate to test for a 'Prelude' import declaration.+    isPrelude :: LImportDecl GhcPs -> Bool+    isPrelude (LL _ x) = fromModuleName' (ideclName x) == "Prelude"+    isPrelude _ = False -- {-# COMPLETE LL #-}++-- Access the imports in scope 'x'.+scopeImports' :: Scope' -> [LImportDecl GhcPs]+scopeImports' (Scope' x) = x++-- Test if two names in two scopes may be referring to the same+-- thing. This is the case if the names are equal and (1) denote a+-- builtin type or data constructor or (2) the intersection of the+-- candidate modules where the two names arise is non-empty.+scopeMatch' :: (Scope', Located RdrName) -> (Scope', Located RdrName) -> Bool+scopeMatch' (a, x) (b, y)+  | isSpecial' x && isSpecial' y = rdrNameStr' x == rdrNameStr' y+  | isSpecial' x || isSpecial' y = False+  | otherwise =+     rdrNameStr' (unqual' x) == rdrNameStr' (unqual' y) && not (null $ possModules' a x `intersect` possModules' b y)++-- Given a name in a scope, and a new scope, create a name for the new+-- scope that will refer to the same thing. If the resulting name is+-- ambiguous, pick a plausible candidate.+scopeMove' :: (Scope', Located RdrName) -> Scope' -> Located RdrName+scopeMove' (a, x@(fromQual' -> Just name)) (Scope' b)+  | null imps = head $ real ++ [x]+  | any (not . ideclQualified) imps = unqual' x+  | otherwise = noLoc $ mkRdrQual (unLoc $ head (mapMaybe ideclAs imps ++ map ideclName imps)) name+  where+    real :: [Located RdrName]+    real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules' a x]++    imps :: [ImportDecl GhcPs]+    imps = [unLoc i | r <- real, i <- b, possImport' i r]+scopeMove' (_, x) _ = x++-- Calculate which modules a name could possibly lie in. If 'x' is+-- qualified but no imported element matches it, assume the user just+-- lacks an import.+possModules' :: Scope' -> Located RdrName -> [String]+possModules' (Scope' is) x = f x+  where+    res :: [String]+    res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport' i x]++    f :: Located RdrName -> [String]+    f n | isSpecial' n = [""]+    f (L _ (Qual mod _)) = [moduleNameString mod | null res] ++ res+    f _ = res++-- Determine if 'x' could possibly lie in the module named by the+-- import declaration 'i'.+possImport' :: LImportDecl GhcPs -> Located RdrName -> Bool+possImport' i n | isSpecial' n = False+possImport' (LL _ i) (L _ (Qual mod x)) =+  moduleNameString mod `elem` map fromModuleName' ms && possImport' (noLoc i{ideclQualified=False}) (noLoc $ mkRdrUnqual x)+  where ms = ideclName i : maybeToList (ideclAs i)+possImport' (LL _ i) (L _ (Unqual x)) = not (ideclQualified i) && maybe True f (ideclHiding i)+  where+    f :: (Bool, Located [LIE GhcPs]) -> Bool+    f (hide, L _ xs) =+      if hide then+        Just True `notElem` ms+      else+        Nothing `elem` ms || Just True `elem` ms+      where ms = map g xs++    tag :: String+    tag = occNameString x++    g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'?+    g (L _ (IEVar _ y)) = Just $ tag == unwrapName y+    g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y+    g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing+    g (L _ (IEThingWith _ y _wildcard ys _fields)) = Just $ tag `elem` unwrapName y : map unwrapName ys+    g _ = Just False++    unwrapName :: LIEWrappedName RdrName -> String+    unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))+possImport' _ _ = False -- {-# COMPLETE LL #-}
+ src/GHC/Util/Unify.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.Unify(+    Subst', fromSubst',+    validSubst', substitute',+    unifyExp'+    ) where++import Control.Monad+import Data.Generics.Uniplate.Operations+import Data.Char+import Data.List.Extra+import Data.Data+import Data.Tuple.Extra+import Util++import HsSyn+import SrcLoc as GHC+import Outputable hiding ((<>))+import RdrName+import OccName++import GHC.Util.Outputable+import GHC.Util.HsExpr+import GHC.Util.Pat+import GHC.Util.RdrName+import GHC.Util.View++isUnifyVar :: String -> Bool+isUnifyVar [x] = x == '?' || isAlpha x+isUnifyVar [] = False+isUnifyVar xs = all (== '?') xs++---------------------------------------------------------------------+-- SUBSTITUTION DATA TYPE++-- A list of substitutions. A key may be duplicated, you need to call+--  'check' to ensure the substitution is valid.+newtype Subst' a = Subst' [(String, a)]+    deriving (Semigroup, Monoid)++-- Unpack the substitution.+fromSubst' :: Subst' a -> [(String, a)]+fromSubst' (Subst' xs) = xs++instance Functor Subst' where+    fmap f (Subst' xs) = Subst' $ map (second f) xs -- Interesting.++instance Outputable a => Show (Subst' a) where+    show (Subst' xs) = unlines [a ++ " = " ++ unsafePrettyPrint b | (a,b) <- xs]++-- Check the unification is valid and simplify it.+validSubst' :: (a -> a -> Bool) -> Subst' a -> Maybe (Subst' a)+validSubst' eq = fmap Subst' . mapM f . groupSort . fromSubst'+    where f (x, y : ys) | all (eq y) ys = Just (x, y)+          f _ = Nothing++-- Peform a substition.+substitute' :: Subst' (LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs+substitute' (Subst' bind) = transformBracketOld' exp . transformBi pat . transformBi typ+  where+    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)+    -- Variables.+    exp (LL _ (HsVar _ x)) = lookup (rdrNameStr' x) bind+    -- Operator applications.+    exp (LL loc (OpApp _ lhs (LL _ (HsVar _ x)) rhs))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (OpApp noExt lhs y rhs))+    -- Left sections.+    exp (LL loc (SectionL _ exp (LL _ (HsVar _ x))))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionL noExt exp y))+    -- Right sections.+    exp (LL loc (SectionR _ (LL _ (HsVar _ x)) exp))+      | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionR noExt y exp))+    exp _ = Nothing++    pat :: LPat GhcPs -> LPat GhcPs+    -- Pattern variables.+    pat (LL _ (VarPat _ x))+      | Just y@(LL _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat' (varToStr' y)+    pat x = x :: LPat GhcPs++    typ :: LHsType GhcPs -> LHsType GhcPs+    -- Type variables.+    typ (LL _ (HsTyVar _ _ x))+      | Just (LL _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr' x) bind = y+    typ x = x :: LHsType GhcPs+++---------------------------------------------------------------------+-- UNIFICATION++type NameMatch' = Located RdrName -> Located RdrName -> Bool++-- | Unification, obeys the property that if @unify a b = s@, then+-- @substitute s a = b@.+unify' :: Data a => NameMatch' -> Bool -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))+unify' nm root x y+    | Just (x, y) <- cast (x, y) = unifyExp' nm root x y+    | Just (x, y) <- cast (x, y) = unifyPat' nm x y+    | Just (x, y) <- cast (x, y) = unifyType' nm x y+    | Just (x :: GHC.SrcSpan) <- cast x = Just mempty+    | otherwise = unifyDef' nm x y++unifyDef' :: Data a => NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))+unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y++-- App/InfixApp are analysed specially for performance reasons. If+-- 'root = True', this is the outside of the expr. Do not expand out a+-- dot at the root, since otherwise you get two matches because of+-- 'readRule' (Bug #570).+unifyExp' :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs) )+-- Brackets are not added when expanding '$' in user code, so tolerate+-- them in the match even if they aren't in the user code.+unifyExp' nm root x y | not root, isPar' x, not $ isPar' y = unifyExp' nm root (fromParen' x) y+-- Don't subsitute for type apps, since no one writes rules imaginging+-- they exist.+unifyExp' nm root (LL _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp' y = Just $ Subst' [(v, y)]+unifyExp' nm root (LL _ (HsVar _ x)) (LL _ (HsVar _ y)) | nm x y = Just mempty++-- Match wildcard operators.+unifyExp' nm root (LL _ (OpApp _ lhs1 (LL _ (HsVar _ (rdrNameStr' -> v))) rhs1))+                  (LL _ (OpApp _ lhs2 (LL _ (HsVar _ (rdrNameStr' -> op2))) rhs2))+    | isUnifyVar v =+        (Subst' [(v, strToVar' op2)] <>) <$>+        liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)+unifyExp' nm root (LL _ (SectionL _ exp1 (LL _ (HsVar _ (rdrNameStr' -> v)))))+                  (LL _ (SectionL _ exp2 (LL _ (HsVar _ (rdrNameStr' -> op2)))))+    | isUnifyVar v = (Subst' [(v, strToVar' op2)] <>) <$> unifyExp' nm False exp1 exp2+unifyExp' nm root (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> v))) exp1))+                  (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> op2))) exp2))+    | isUnifyVar v = (Subst' [(v, strToVar' op2)] <>) <$> unifyExp' nm False exp1 exp2++-- Options: match directly, and expand through '.'+unifyExp' nm root x@(LL _ (HsApp _ x1 x2)) (LL _ (HsApp _ y1 y2)) =+    liftM2 (<>) (unifyExp' nm False x1 y1) (unifyExp' nm False x2 y2) `mplus`+    (do guard $ not root+            -- Don't expand '.' f at the root, otherwise you can get+            -- duplicate matches because the matching engine+            -- auto-generates hints in dot-form.+        (LL _ (OpApp _ y11 dot y12)) <- return $ fromParen' y1+        guard $ isDot' dot+        unifyExp' nm root x (noLoc (HsApp noExt y11 (noLoc (HsApp noExt y12 y2))))+    )++-- Options: match directly, then expand through '$', then desugar infix.+unifyExp' nm root x (LL _ (OpApp _ lhs2 op2@(LL _ (HsVar _ op2')) rhs2))+    | (LL _ (OpApp _ lhs1 op1@(LL _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)+    | isDol' op2 = unifyExp' nm root x $ noLoc (HsApp noExt lhs2 rhs2)+    | otherwise  = unifyExp' nm root x $ noLoc (HsApp noExt (noLoc (HsApp noExt op2 lhs2)) rhs2)++unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y+    where+        -- Types that are not already handled in unify.+        {-# INLINE isOther #-}+        isOther :: LHsExpr GhcPs -> Bool+        isOther (LL _ HsVar{}) = False+        isOther (LL _ HsApp{}) = False+        isOther (LL _ OpApp{}) = False+        isOther _ = True++unifyExp' _ _ _ _ = Nothing+++unifyPat' :: NameMatch' -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))+unifyPat' nm (LL _ (VarPat _ x)) (LL _ (VarPat _ y)) =+  Just $ Subst' [(rdrNameStr' x, strToVar'(rdrNameStr' y))]+unifyPat' nm (LL _ (VarPat _ x)) (LL _ (WildPat _)) =+  let s = rdrNameStr' x in Just $ Subst' [(s, strToVar'("_" ++ s))]+unifyPat' nm (LL _ (ConPatIn x _)) (LL _ (ConPatIn y _)) | rdrNameStr' x /= rdrNameStr' y =+  Nothing+unifyPat' nm x y =+  unifyDef' nm x y++unifyType' :: NameMatch' -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))+unifyType' nm (LL loc (HsTyVar _ _ x)) y =+  let wc = HsWC noExt y :: LHsWcType (NoGhcTc GhcPs)+      unused = noLoc (HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc "__unused__"))) :: LHsExpr GhcPs+      appType = cL loc (HsAppType noExt unused wc) :: LHsExpr GhcPs+ in Just $ Subst' [(rdrNameStr' x, appType)]+unifyType' nm x y = unifyDef' nm x y
src/GHC/Util/W.hs view
@@ -27,6 +27,7 @@ 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+instance Outputable a => Show (W a) where show = wToStr  wrap :: a -> W a wrap = W
src/Grep.hs view
@@ -10,6 +10,10 @@ import Util import Idea +import qualified HsSyn as GHC+import qualified BasicTypes as GHC+import GHC.Util+import SrcLoc as GHC hiding (mkSrcSpan)  runGrep :: String -> ParseFlags -> [FilePath] -> IO () runGrep patt flags files = do@@ -20,7 +24,10 @@                           patt ++ "\n" ++                           replicate (srcColumn sl - 1) ' ' ++ "^"     let scope = scopeCreate $ Module an Nothing [] [] []-    let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing []]+    let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed+    let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing []+                         -- Todo : Replace these with "proper" GHC expressions.+                          (wrap mempty) (wrap unit) (wrap unit) Nothing]     forM_ files $ \file -> do         res <- parseModuleEx flags file Nothing         case res of
src/HSE/All.hs view
@@ -9,7 +9,8 @@     ParseError(..), ModuleEx(..),     parseModuleEx, ghcComments,     freeVars, vars, varss, pvars,-    ghcSpanToHSE, ghcSrcLocToHSE+    ghcSpanToHSE, ghcSrcLocToHSE,+    parseExpGhcWithMode, parseImportDeclGhcWithMode     ) where  import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))@@ -42,6 +43,7 @@ import qualified GHC.LanguageExtensions.Type as GHC import qualified ApiAnnotation as GHC import qualified BasicTypes as GHC+import qualified DynFlags as GHC  import GHC.Util import qualified GHC.Util.Refact.Fixity as GHC@@ -264,23 +266,10 @@                ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)    return $ Left $ ParseError sl msg pe --- | Produce a pair of lists from a 'ParseFlags' value representing--- language extensions to explicitly enable/disable.-ghcExtensionsFromParseFlags :: ParseFlags-                             -> ([GHC.Extension], [GHC.Extension])-ghcExtensionsFromParseFlags ParseFlags {hseFlags=ParseMode {extensions=exts}}=-   partitionEithers $ mapMaybe toEither exts-   where-     toEither ke = case ke of-       EnableExtension e  -> Left  <$> readExtension (show e)-       DisableExtension e -> Right <$> readExtension (show e)-       UnknownExtension ('N':'o':e) -> Right <$> readExtension e-       UnknownExtension e -> Left <$> readExtension e- -- 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}} =+ghcFixitiesFromParseMode :: ParseMode -> [(String, GHC.Fixity)]+ghcFixitiesFromParseMode ParseMode {fixities=Just fixities} =   concatMap convert fixities   where     convert (Fixity (AssocNone _) fix name) = infix_' fix [qNameToStr name]@@ -301,7 +290,46 @@     qNameToStr (UnQual _ (X.Ident _ x)) = x     qNameToStr (UnQual _ (Symbol _ x)) = x     qNameToStr _ = ""-ghcFixitiesFromParseFlags _ = []+ghcFixitiesFromParseMode _ = []++-- GHC enabled/disabled extensions given an HSE parse mode.+ghcExtensionsFromParseMode :: ParseMode+                           -> ([GHC.Extension], [GHC.Extension])+ghcExtensionsFromParseMode ParseMode {extensions=exts}=+   partitionEithers $ mapMaybe toEither exts+   where+     toEither ke = case ke of+       EnableExtension e  -> Left  <$> readExtension (show e)+       DisableExtension e -> Right <$> readExtension (show e)+       UnknownExtension ('N':'o':e) -> Right <$> readExtension e+       UnknownExtension e -> Left <$> readExtension e++-- GHC extensions to enable/disable given HSE parse flags.+ghcExtensionsFromParseFlags :: ParseFlags+                             -> ([GHC.Extension], [GHC.Extension])+ghcExtensionsFromParseFlags ParseFlags {hseFlags=mode} = ghcExtensionsFromParseMode mode++-- GHC fixities given HSE parse flags.+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]+ghcFixitiesFromParseFlags ParseFlags {hseFlags=mode} = ghcFixitiesFromParseMode mode++-- These next two functions get called frorm 'Config/Yaml.hs' for user+-- defined hint rules.++parseExpGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LHsExpr HsSyn.GhcPs)+parseExpGhcWithMode parseMode s =+  let (enable, disable) = ghcExtensionsFromParseMode parseMode+      flags = foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable+      fixities = ghcFixitiesFromParseMode parseMode+  in case parseExpGhcLib s flags of+    GHC.POk pst a -> GHC.POk pst a' where (_, a') = GHC.applyFixities Map.empty fixities a+    f@GHC.PFailed{} -> f++parseImportDeclGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LImportDecl HsSyn.GhcPs)+parseImportDeclGhcWithMode parseMode s =+  let (enable, disable) = ghcExtensionsFromParseMode parseMode+      flags = foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable+  in parseImportGhcLib s flags  -- | Parse a Haskell module. Applies the C pre processor, and uses -- best-guess fixity resolution if there are ambiguities.  The
src/HSE/Unify.hs view
@@ -19,7 +19,6 @@ import Util import Prelude - --------------------------------------------------------------------- -- SUBSTITUTION DATA TYPE @@ -126,7 +125,8 @@             -- because the matching engine auto-generates hints in dot-form         InfixApp _ y11 dot y12 <- return $ fromParen y1         guard $ isDot dot-        unifyExp nm root x (App an y11 (App an y12 y2)))+        unifyExp nm root x (App an y11 (App an y12 y2))+    )  -- Options: match directly, then expand through $, then desugar infix unifyExp nm root x (InfixApp _ lhs2 op2 rhs2)
src/Hint/All.hs view
@@ -77,8 +77,14 @@  -- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'. resolveHints :: [Either HintBuiltin HintRule] -> Hint-resolveHints xs = mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nubOrd lefts)-    where (lefts,rights) = partitionEithers xs+resolveHints xs =+  if False then+      -- GHC+    mconcat $ mempty{hintDecl'=const $ readMatch' rights} : map builtin (nubOrd lefts)+  else+      -- HSE+    mconcat $ mempty{ hintDecl=const $  readMatch rights} : map builtin (nubOrd lefts)+  where (lefts,rights) = partitionEithers xs  -- | Transform a list of 'HintRule' into a 'Hint'. hintRules :: [HintRule] -> Hint
src/Hint/Bracket.hs view
@@ -166,7 +166,7 @@       | isAtom' x       , not $ isPartialAtom x =           bracketError msg o x : g x-    -- In some context, removing parentheses from 'x' succeds. Does+    -- In some context, removing parentheses from 'x' succeeds. Does     -- 'x' actually need bracketing in this context?     f (Just (i, o, gen)) v@(remParens' -> Just x)       | not $ needBracket' i o x, not $ isPartialAtom x =
src/Hint/ListRec.hs view
@@ -24,6 +24,7 @@ f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs f [] y = y; f (x:xs) y = f xs (f xs z)+fun [] = []; fun (x:xs) = f x xs ++ fun xs </TEST> -} @@ -101,7 +102,8 @@     = 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]+    | [] <- vs, App2' op lhs rhs <- view' cons+    , xs `notElem` (vars' op ++ vars' lhs) -- the meaning of xs changes, see #793     , eqNoLoc' (fromParen' rhs) recursive     = Just $ (,,) "foldr" Suggestion $       appsBracket' [ strToVar' "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar' xs]
src/Hint/Match.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-} +-- Keep until 'checkSide', 'checkDefine', ... are used.+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+ {- The matching does a fairly simple unification between the two terms, treating any single letter variable on the left as a free variable. After the matching@@ -37,7 +40,7 @@ not . not . x ==> x -} -module Hint.Match(readMatch) where+module Hint.Match(readMatch,readMatch') where  import Control.Applicative import Data.List.Extra@@ -53,6 +56,13 @@ import Prelude import qualified Refact.Types as R +import qualified HsSyn as GHC+import qualified SrcLoc as GHC+import qualified BasicTypes as GHC+import RdrName+import OccName+import Data.Data+import GHC.Util  fmapAn :: Exp b -> Exp SrcSpanInfo fmapAn = fmap (const an)@@ -61,10 +71,18 @@ --------------------------------------------------------------------- -- READ THE RULE +-- old+ readMatch :: [HintRule] -> DeclHint readMatch settings = findIdeas (concatMap readRule settings) +-- new +readMatch' :: [HintRule] -> Scope' -> ModuleEx -> GHC.LHsDecl GHC.GhcPs -> [Idea]+readMatch' settings = findIdeas' (concatMap readRule' settings)++-- old+ readRule :: HintRule -> [HintRule] readRule m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)} =     (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ do@@ -79,7 +97,29 @@             ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]          else [] +-- new +readRule' :: HintRule -> [HintRule]+readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unwrap -> hintRuleGhcLHS)+                    , hintRuleGhcRHS=(stripLocs' . unwrap -> hintRuleGhcRHS)+                    , hintRuleGhcSide=((stripLocs' . unwrap <$>) -> hintRuleGhcSide)+                    } =+   (:) m{ hintRuleGhcLHS=wrap hintRuleGhcLHS+        , hintRuleGhcRHS=wrap hintRuleGhcRHS+        , hintRuleGhcSide=wrap <$> hintRuleGhcSide } $ do+    (l, v1) <- dotVersion' hintRuleGhcLHS+    (r, v2) <- dotVersion' hintRuleGhcRHS+    guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r))+    if not (null r) then+      [ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (dotApps' r), hintRuleGhcSide=wrap <$> hintRuleGhcSide }+      , m{ hintRuleGhcLHS=wrap (dotApps' (l ++ [strToVar' v1])), hintRuleGhcRHS=wrap (dotApps' (r ++ [strToVar' v1])), hintRuleGhcSide=wrap <$> hintRuleGhcSide } ]+      else if length l > 1 then+            [ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (strToVar' "id"), hintRuleGhcSide=wrap <$> hintRuleGhcSide }+            , m{ hintRuleGhcLHS=wrap (dotApps' (l++[strToVar' v1])), hintRuleGhcRHS=wrap (strToVar' v1), hintRuleGhcSide=wrap <$> hintRuleGhcSide}]+      else []++-- old+ -- find a dot version of this rule, return the sequence of app prefixes, and the var dotVersion :: Exp_ -> [([Exp_], String)] dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)]@@ -88,10 +128,22 @@                                  (first (RightSection l op y:) <$> dotVersion x) dotVersion _ = [] +-- new +-- Find a dot version of this rule, return the sequence of app+-- prefixes, and the var.+dotVersion' :: GHC.LHsExpr GHC.GhcPs -> [([GHC.LHsExpr GHC.GhcPs], String)]+dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)]+dotVersion' (GHC.LL _ (GHC.HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)+dotVersion' (GHC.LL l (GHC.OpApp _ x op y)) =(first (GHC.cL l (GHC.SectionL GHC.noExt x op) :) <$> dotVersion' y) +++                                             (first (GHC.cL l (GHC.SectionR GHC.noExt op y) :) <$> dotVersion' x)+dotVersion' _ = []+ --------------------------------------------------------------------- -- PERFORM THE MATCHING +-- old+ findIdeas :: [HintRule] -> Scope -> ModuleEx -> Decl_ -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList     [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}@@ -100,11 +152,33 @@     , m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]     , let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ] +-- new++findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> GHC.LHsDecl GHC.GhcPs -> [Idea]+findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList+    [ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}+    | decl <- findDecls' decl+    , (parent,x) <- universeParentExp' decl+    , m <- matches, Just (y, notes, subst) <- [matchIdea' s decl m parent x]+    , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unwrap (hintRuleGhcRHS m))+    ]++-- old+ findDecls :: Decl_ -> [Decl_] findDecls x@InstDecl{} = children x-findDecls RulePragmaDecl{} = [] -- often rules contain things that HLint would rewrite+findDecls RulePragmaDecl{} = []  -- often rules contain things that HLint would rewrite findDecls x = [x] +-- new++findDecls' :: GHC.LHsDecl GHC.GhcPs -> [GHC.LHsDecl GHC.GhcPs]+findDecls' x@(GHC.LL _ GHC.InstD{}) = children x+findDecls' (GHC.LL _ GHC.RuleD{}) = [] -- Often rules contain things that HLint would rewrite.+findDecls' x = [x]++-- old+ matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)]) matchIdea s decl HintRule{..} parent x = do     let nm a b = scopeMatch (hintRuleScope,a) (s,b)@@ -127,10 +201,45 @@     guard $ checkDefine decl parent res     return (res, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, ann pos /= an]) +-- new +matchIdea' :: Scope'+           -> GHC.LHsDecl GHC.GhcPs+           -> HintRule+           -> Maybe (Int, GHC.LHsExpr GHC.GhcPs)+           -> GHC.LHsExpr GHC.GhcPs+           -> Maybe (GHC.LHsExpr GHC.GhcPs, [Note], [(String, R.SrcSpan)])+matchIdea' sb decl HintRule{..} parent x = do+  let lhs = unwrap hintRuleGhcLHS+      rhs = unwrap hintRuleGhcRHS+      sa  = unwrap hintRuleGhcScope+      nm a b = scopeMatch' (sa, a) (sb, b)+  u <- unifyExp' nm True lhs x+  u <- validSubst' eqNoLoc' u++  -- Need to check free vars before unqualification, but after subst+  -- (with 'e') need to unqualify before substitution (with 'res').+  let e = substitute' u rhs+      res = addBracket' parent $ performSpecial' $ substitute' u $ unqualify' sa sb rhs+  guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs)) `Set.isSubsetOf` freeVars' x+      -- Check no unexpected new free variables.++  -- Check it isn't going to get broken by QuasiQuotes as per #483. If+  -- we have lambdas we might be moving, and QuasiQuotes, we might+  -- inadvertantly break free vars because quasi quotes don't show+  -- what free vars they make use of.+  guard $ not (any isLambda' $ universe lhs) || not (any isQuasiQuote' $ universe x)++  guard $ checkSide' (unwrap <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u+  guard $ checkDefine' decl parent res++  return (res, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, GHC.getLoc pos /= GHC.noSrcSpan])+ --------------------------------------------------------------------- -- SIDE CONDITIONS +-- old+ checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool checkSide x bind = maybe True bool x     where@@ -163,8 +272,13 @@         isType "Pos" (asInt -> Just x) | x >  0 = True         isType "Neg" (asInt -> Just x) | x <  0 = True         isType "NegZero" (asInt -> Just x) | x <= 0 = True-        isType ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ-        isType typ x = head (words $ show x) == typ+        isType ('L':'i':'t':typ@(_:_)) (Lit _ x) =+           -- This case only comes up in the tests with 'LitInt'.+          let top = head (words $ show x) in+          typ == top+        isType typ x =+          let top = head (words $ show x) in+          typ == top          asInt :: Exp_ -> Maybe Integer         asInt (Paren _ x) = asInt x@@ -181,16 +295,88 @@             where f (view -> Var_ x) | Just y <- lookup x bind = y                   f x = x +-- new +checkSide' :: Maybe (GHC.LHsExpr GHC.GhcPs) -> [(String, GHC.LHsExpr GHC.GhcPs)] -> Bool+checkSide' x bind = maybe True bool x+    where+      bool :: GHC.LHsExpr GHC.GhcPs -> Bool+      bool (GHC.LL _ (GHC.OpApp _ x op y))+        | varToStr' op == "&&" = bool x && bool y+        | varToStr' op == "||" = bool x || bool y+        | varToStr' op == "==" = expr (fromParen1' x) `eqNoLoc'` expr (fromParen1' y)+      bool (GHC.LL _ (GHC.HsApp _ x y)) | varToStr' x == "not" = not $ bool y+      bool (GHC.LL _ (GHC.HsPar _ x)) = bool x++      bool (GHC.LL _ (GHC.HsApp _ cond (sub -> y)))+        | 'i' : 's' : typ <- varToStr' cond = isType typ y+      bool (GHC.LL _ (GHC.HsApp _ (GHC.LL _ (GHC.HsApp _ cond (sub -> x))) (sub -> y)))+          | varToStr' cond == "notIn" = and [wrap (stripLocs' x) `notElem` map (wrap . stripLocs') (universe y) | x <- list x, y <- list y]+          | varToStr' cond == "notEq" = not (x `eqNoLoc'` y)+      bool x | varToStr' x == "noTypeCheck" = True+      bool x | varToStr' x == "noQuickCheck" = True+      bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x++      expr :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+      expr (GHC.LL _ (GHC.HsApp _ (varToStr' -> "subst") x)) = sub $ fromParen1' x+      expr x = x++      isType "Compare" x = True -- Just a hint for proof stuff+      isType "Atom" x = isAtom' x+      isType "WHNF" x = isWHNF' x+      isType "Wildcard" x = any isFieldPun' (universeBi x) || any hasFieldsDotDot' (universeBi x)+      isType "Nat" (asInt -> Just x) | x >= 0 = True+      isType "Pos" (asInt -> Just x) | x >  0 = True+      isType "Neg" (asInt -> Just x) | x <  0 = True+      isType "NegZero" (asInt -> Just x) | x <= 0 = True+      isType "LitInt" (GHC.LL _ (GHC.HsLit _ GHC.HsInt{})) = True+      isType "LitInt" (GHC.LL _ (GHC.HsOverLit _ (GHC.OverLit _ GHC.HsIntegral{} _))) = True+      isType "Var" (GHC.LL _ GHC.HsVar{}) = True+      isType "App" (GHC.LL _ GHC.HsApp{}) = True+      isType "InfixApp" (GHC.LL _ x@GHC.OpApp{}) = True+      isType "Paren" (GHC.LL _ x@GHC.HsPar{}) = True+      isType "Tuple" (GHC.LL _ GHC.ExplicitTuple{}) = True++      isType typ (GHC.LL _ x) =+        let top = showConstr (toConstr x) in+        typ == top+      isType _ _ = False -- {-# COMPLETE LL#-}++      asInt :: GHC.LHsExpr GHC.GhcPs -> Maybe Integer+      asInt (GHC.LL _ (GHC.HsPar _ x)) = asInt x+      asInt (GHC.LL _ (GHC.NegApp _ x _)) = negate <$> asInt x+      asInt (GHC.LL _ (GHC.HsLit _ (GHC.HsInt _ (GHC.IL _ neg x)) )) = Just $ if neg then -x else x+      asInt (GHC.LL _ (GHC.HsOverLit _ (GHC.OverLit _ (GHC.HsIntegral (GHC.IL _ neg x)) _))) = Just $ if neg then -x else x+      asInt _ = Nothing++      list :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]+      list (GHC.LL _ (GHC.ExplicitList _ _ xs)) = xs+      list x = [x]++      sub :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+      sub = transform f+        where f (view' -> Var_' x) | Just y <- lookup x bind = y+              f x = x++-- old+ -- does the result look very much like the declaration checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y) checkDefine _ _ _ = True +-- new +-- Does the result look very much like the declaration?+checkDefine' :: GHC.LHsDecl GHC.GhcPs -> Maybe (Int, GHC.LHsExpr GHC.GhcPs) -> GHC.LHsExpr GHC.GhcPs -> Bool+checkDefine' x Nothing y = declName x /= Just (varToStr' (transformBi unqual' $ head $ fromApps' y))+checkDefine' _ _ _ = True+ --------------------------------------------------------------------- -- TRANSFORMATION +-- old+ -- if it has _eval_ do evaluation on it performSpecial :: Exp_ -> Exp_ performSpecial = transform fNoParen . fEval@@ -201,6 +387,20 @@         fNoParen (App _ e x) | e ~= "_noParen_" = fromParen x         fNoParen x = x +-- new++-- If it has '_eval_' do evaluation on it.+performSpecial' :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+performSpecial' = transform fNoParen . fEval+  where+    fEval, fNoParen :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+    fEval (GHC.LL _ (GHC.HsApp _ e x)) | varToStr' e == "_eval_" = reduce' x+    fEval x = x+    fNoParen (GHC.LL _ (GHC.HsApp _ e x)) | varToStr' e == "_noParen_" = fromParen' x+    fNoParen x = x++-- old+ -- contract Data.List.foo ==> foo, if Data.List is loaded unqualify :: Scope -> Scope -> Exp_ -> Exp_ unqualify from to = transformBi f@@ -208,7 +408,24 @@         f x@(UnQual _ (Ident _ s)) | isUnifyVar s = x         f x = scopeMove (from,x) to +-- new +-- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.+unqualify' :: Scope' -> Scope' -> GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+unqualify' from to = transformBi f+  where+    f :: GHC.Located RdrName -> GHC.Located RdrName+    f x@(GHC.L _ (Unqual s)) | isUnifyVar (occNameString s) = x+    f x = scopeMove' (from, x) to++-- old+ addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_ addBracket (Just (i,p)) c | needBracketOld i p c = Paren an c addBracket _ x = x++-- new++addBracket' :: Maybe (Int, GHC.LHsExpr GHC.GhcPs) -> GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs+addBracket' (Just (i, p)) c | needBracketOld' i p c = GHC.noLoc $ GHC.HsPar GHC.noExt c+addBracket' _ x = x
src/Hint/Type.hs view
@@ -12,9 +12,10 @@ import Refact   as Export import HsExtension import HsDecls+import GHC.Util.Scope  type DeclHint = Scope -> ModuleEx -> Decl_ -> [Idea]-type DeclHint' = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]+type DeclHint' = Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea] type ModuHint = Scope -> ModuleEx -> [Idea] type CrossHint = [(Scope, ModuleEx)] -> [Idea] @@ -23,7 +24,7 @@     { hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.     , hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.     , hintDecl :: [Setting] -> Scope -> ModuleEx -> Decl SrcSpanInfo -> [Idea]-    , hintDecl' :: [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]+    , hintDecl' :: [Setting] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea]         -- ^ Given a declaration (with a module and scope) generate some 'Idea's.         --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.     }
src/Test/Translate.hs view
@@ -64,7 +64,7 @@     ,"main = return ()"] ++     ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++      prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing)-    | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)+    | (i, HintRule _ _ _ lhs rhs side _notes  _ghcScope  _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side)     , let vs = map toNamed $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs     , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)     , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]@@ -88,7 +88,7 @@                 Let an (BDecls an [PatBind an (toNamed "t") (UnGuardedRhs an bod) Nothing]) $                 (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`                  str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t"-            | (i, HintRule _ _ _ lhs rhs side note) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)+            | (i, HintRule _ _ _ lhs rhs side note _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side)             , let vs = map (restrict side) $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs             , let op = if any isRemovesError note then "?==>" else "==>"             , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs)