diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,58 @@ Changelog for HLint (* = breaking change) +3.0, released 2020-05-02 + Be more permissive with names'with'quotes'in + #953, fix incorrect suggestions with free variables and \case + #955, make --find generate fixity: not infix: + #952, improve refactorings with qualified imports + #945, suggest Map.fromList [] ==> Map.empty + #949, warn about redundant fmaps with binds + #950, reduce the span of "Redundant $" to only cover the "$" + #944, reduce the span of "Use let" to only cover the "let" line + #669, don't suggest replacing reverse . sort (it's quite fast) + #939, reduce the span of "Redundant where" to only cover the "where" + Remove support for GHC 8.4 + Remove support for _eval, + #926, fix refactoring when the hint contains _noParen_ + #933, improve the output for Redundant do hints +* Merge ParseMode into ParseFlags +* Rename Language.Haskell.HLint3,HLint4 to Language.Haskell.HLint +* Delete the old Language.Haskell.HLint + #881, add a monomorphic group of hints + #837, don't suggest redundant do if its being used for brackets + #923, don't suggest eta reducing infix definitions + #931, disable StaticPointers extension by default + #924, remove dependency on haskell-src-exts + #922, reduce the span of "Redundant do" to only cover the "do" + #919, more specific names for foldMap fusion rules + #918, warn on unused TypeOperators + #916, warn on unused InstanceSigs + Improve parse error context messages +* Most parse errors are fixed + #881, disable hints about maybe that are sometimes wrong + #909, be more careful about redundant bracket warnings + #905, match hints even if there is composition to the left + #904, suggest map/fromMaybe[] becomes maybe [] map +* Remove the hse command line argument, to parse a file with HSE + #901, warn on unused MultiWayIf + Don't raise a parse error if haskell-src-exts can't parse code + #899, warn on unused PatternSynonyms + #898, don't suggest removing NamedFieldPuns with record updates +* Make any --hint flag disable implicit .hlint.yaml search +* Delete the --with flag +* Haskell hint definitions are no longer supported (use YAML) +* Report hints with src-span information, e.g. file:1:1-10 +* Delete resolveHints (it was the identity) +* Change to GHC types in the API + Add --with-group=future to add return ==> pure hint + #888, suggest foldr from (.) to ($) in some cases + #884, add more >=> operator hints + #875, fix the extension implication information + Add --with-group=extra to give extra library hints + #873, add more Applicative hints + #872, fix refactoring in hints to use lists + #871, warn when fmapping the result of gets or asks + #869, improve hints for maybe/fromMaybe on Bool 2.2.11, released 2020-02-09 #868, fix some brackets in refactoring suggestions #865, suggest biList if generalise-for-conciseness is turned on diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,7 +14,10 @@ * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. * Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. +* Sometimes HLint will change the code in a way that causes values to default to different types, which may change the behaviour. +* HLint assumes duplicate identical expressions within in a single expression are used at the same type. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes. +* HLint can be configured with knowledge of C Pre Processor flags, but it can only see one conditional set of code at a time. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`, `foo $bar` means something different with `TemplateHaskell`. These extensions can be disabled with `-XNoMagicHash` or `-XNoTemplateHaskell` etc. * HLint doesn't run any custom preprocessors, e.g. [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) or [record-dot-preprocessor](https://hackage.haskell.org/package/record-dot-preprocessor), so code making use of them will usually fail to parse. @@ -95,7 +98,7 @@ By supplying the `--refactor` flag hlint can automatically apply most suggestions. Instead of a list of hints, hlint will instead output the refactored file on stdout. In order to do this, it is necessary to have the -`refactor` executable on you path. `refactor` is provided by the +`refactor` executable on your path. `refactor` is provided by the [`apply-refact`](https://github.com/mpickering/apply-refact) package, it uses the GHC API in order to transform source files given a list of refactorings to apply. Hlint directly calls the executable to apply the diff --git a/data/HLint_QuickCheck.hs b/data/HLint_QuickCheck.hs --- a/data/HLint_QuickCheck.hs +++ b/data/HLint_QuickCheck.hs @@ -102,7 +102,6 @@ Right v -> Just v _noParen_ = id -_eval_ = id withMain :: IO () -> IO () withMain act = do diff --git a/data/HLint_TypeCheck.hs b/data/HLint_TypeCheck.hs --- a/data/HLint_TypeCheck.hs +++ b/data/HLint_TypeCheck.hs @@ -6,7 +6,6 @@ (==>) = undefined _noParen_ = id -_eval_ = id --------------------------------------------------------------------- diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -102,7 +102,8 @@ - warn: {lhs: sortBy (flip (comparing f)), rhs: sortOn (Down . f)} - warn: {lhs: sortBy (comparing f), rhs: sortOn f, side: notEq f fst && notEq f snd} - warn: {lhs: reverse (sortOn f x), rhs: sortOn (Data.Ord.Down . f) x, name: Avoid reverse, note: Stabilizes sort order} - - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order} + # This suggestion likely costs performance, see https://github.com/ndmitchell/hlint/issues/669#issuecomment-607154496 + # - warn: {lhs: reverse (sort x), rhs: sortOn Data.Ord.Down x, name: Avoid reverse, note: Stabilizes sort order} - hint: {lhs: flip (g `on` h), rhs: flip g `on` h, name: Move flip} - hint: {lhs: (f `on` g) `on` h, rhs: f `on` (g . h), name: Fuse on/on} @@ -142,6 +143,7 @@ - warn: {lhs: foldl f (head x) (tail x), rhs: foldl1 f x} - warn: {lhs: foldr f (last x) (init x), rhs: foldr1 f x} - warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"} + - warn: {lhs: foldr (.) id l z, rhs: foldr ($) z l} - warn: {lhs: span (not . p), rhs: break p} - warn: {lhs: break (not . p), rhs: span p} - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness} @@ -175,6 +177,7 @@ - hint: {lhs: 0 /= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null} - hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"} - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)} + - hint: {lhs: "map f (fromMaybe [] x)", rhs: "maybe [] (map f) x"} - warn: {lhs: not (elem x y), rhs: notElem x y} - hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map} - warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"} @@ -239,8 +242,8 @@ - warn: {lhs: foldMap id, rhs: fold} - warn: {lhs: fold (fmap f x), rhs: foldMap f x} - warn: {lhs: fold (map f x), rhs: foldMap f x} - - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x} - - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x} + - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x, name: Fuse foldMap/fmap} + - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x, name: Fuse foldMap/map} # BY @@ -344,8 +347,6 @@ - warn: {lhs: if x then False else y, rhs: not x && y, side: notEq y True, name: Redundant if} - warn: {lhs: if x then y else True, rhs: not x || y, side: notEq y False, name: Redundant if} - warn: {lhs: not (not x), rhs: x, name: Redundant not} - # warn "Too strict if": {lhs: if c then f x else f y, rhs: f (if c then x else y), note: IncreasesLaziness} - # also breaks types, see #87 # ARROW @@ -414,6 +415,12 @@ - warn: {lhs: liftA, rhs: fmap} - hint: {lhs: m >>= return . f, rhs: f <$> m} - hint: {lhs: return . f =<< m, rhs: f <$> m} + - warn: {lhs: fmap f x >>= g, rhs: x >>= g . f} + - warn: {lhs: f <$> x >>= g, rhs: x >>= g . f} + - warn: {lhs: x Data.Functor.<&> f >>= g, rhs: x >>= g . f} + - warn: {lhs: g =<< fmap f x, rhs: g . f =<< x} + - warn: {lhs: g =<< f <$> x, rhs: g . f =<< x} + - warn: {lhs: g =<< (x Data.Functor.<&> f), rhs: g . f =<< x} - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)} - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y} - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y} @@ -443,8 +450,15 @@ - warn: {lhs: flip (=<<), rhs: (>>=)} - hint: {lhs: \x -> f x >>= g, rhs: f Control.Monad.>=> g} - hint: {lhs: \x -> f =<< g x, rhs: f Control.Monad.<=< g} + - hint: {lhs: (>>= f) . g, rhs: f Control.Monad.<=< g} + - hint: {lhs: (f =<<) . g, rhs: f Control.Monad.<=< g} - warn: {lhs: a >> forever a, rhs: forever a} - hint: {lhs: liftM2 id, rhs: ap} + - warn: {lhs: liftA2 f (return x), rhs: fmap (f x)} + - warn: {lhs: liftM2 f (pure x), rhs: fmap (f x)} + - warn: {lhs: liftM2 f (return x), rhs: fmap (f x)} + - warn: {lhs: fmap f (return x), rhs: return (f x)} + - warn: {lhs: f <$> return x, rhs: return (f x)} - warn: {lhs: mapM (uncurry f) (zip l m), rhs: zipWithM f l m} - warn: {lhs: mapM_ (void . f), rhs: mapM_ f} - warn: {lhs: forM_ x (void . f), rhs: forM_ x f} @@ -484,6 +498,9 @@ - warn: {lhs: foldr (*>) (pure ()), rhs: sequenceA_} - warn: {lhs: foldr (<|>) empty, rhs: asum} - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)} + - warn: {lhs: liftA2 f (pure x), rhs: fmap (f x)} + - warn: {lhs: fmap f (pure x), rhs: pure (f x)} + - warn: {lhs: f <$> pure x, rhs: pure (f x)} - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a} - hint: {lhs: m >>= pure . f, rhs: f <$> m} - hint: {lhs: pure . f =<< m, rhs: f <$> m} @@ -518,8 +535,12 @@ - warn: {lhs: maybe Nothing Just, rhs: id, name: Redundant maybe} - warn: {lhs: maybe False (const True), rhs: Data.Maybe.isJust} - warn: {lhs: maybe True (const False), rhs: Data.Maybe.isNothing} - - warn: {lhs: maybe False (== x), rhs: (== Just x)} - - warn: {lhs: maybe True (/= x), rhs: (/= Just x)} + - warn: {lhs: maybe False (x ==), rhs: (Just x ==)} + - warn: {lhs: maybe True (x /=), rhs: (Just x /=)} + - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x} + - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x} + - warn: {lhs: fromMaybe False, rhs: (Just True ==)} + - warn: {lhs: fromMaybe True, rhs: (Just False /=)} - warn: {lhs: not (isNothing x), rhs: isJust x} - warn: {lhs: not (isJust x), rhs: isNothing x} - warn: {lhs: "maybe [] (:[])", rhs: maybeToList} @@ -551,8 +572,6 @@ - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m} - hint: {lhs: maybe Nothing id, rhs: join} - hint: {lhs: maybe Nothing f x, rhs: f =<< x} - - hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe} - - hint: {lhs: maybe (f x) f y, rhs: f (Data.Maybe.fromMaybe x y), note: IncreasesLaziness, name: Too strict maybe} - 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} @@ -652,8 +671,12 @@ - warn: {lhs: f <$> Control.Monad.State.get, rhs: gets f} - warn: {lhs: fmap f Control.Monad.State.get, rhs: gets f} + - warn: {lhs: f <$> Control.Monad.State.gets g, rhs: gets (f . g)} + - warn: {lhs: fmap f (Control.Monad.State.gets g), rhs: gets (f . g)} - warn: {lhs: f <$> Control.Monad.Reader.ask, rhs: asks f} - warn: {lhs: fmap f Control.Monad.Reader.ask, rhs: asks f} + - warn: {lhs: f <$> Control.Monad.Reader.asks g, rhs: asks (f . g)} + - warn: {lhs: fmap f (Control.Monad.Reader.asks g), rhs: asks (f . g)} - warn: {lhs: fst (runState m s), rhs: evalState m s} - warn: {lhs: snd (runState m s), rhs: execState m s} @@ -742,6 +765,12 @@ - warn: {lhs: null x , rhs: "False", side: isTuple x, name: Using null on tuple} - warn: {lhs: length x, rhs: "1" , side: isTuple x, name: Using length on tuple} + # MAP + + - warn: {lhs: "Data.Map.fromList []", rhs: Data.Map.empty} + - warn: {lhs: "Data.Map.Lazy.fromList []", rhs: Data.Map.Lazy.empty} + - warn: {lhs: "Data.Map.Strict.fromList []", rhs: Data.Map.Strict.empty} + - group: name: lens enabled: true @@ -811,8 +840,6 @@ - warn: {lhs: either (const False), rhs: any} - warn: {lhs: either (const True), rhs: all} - warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold} - - warn: {lhs: Data.Maybe.fromMaybe False, rhs: or} - - warn: {lhs: Data.Maybe.fromMaybe True, rhs: and} - warn: {lhs: Data.Maybe.fromMaybe 0, rhs: sum} - warn: {lhs: Data.Maybe.fromMaybe 1, rhs: product} - warn: {lhs: Data.Maybe.fromMaybe empty, rhs: Data.Foldable.asum} @@ -831,7 +858,78 @@ - hint: {lhs: "[fst x, snd x]", rhs: Data.Bifoldable.biList x} - hint: {lhs: "\\(x, y) -> [x, y]", rhs: Data.Bifoldable.biList, note: IncreasesLaziness} +# hints that use the 'extra' library - group: + name: extra + enabled: false + rules: + - warn: {lhs: fmap concat (forM a b), rhs: concatForM a b} + - warn: {lhs: concat <$> forM a b, rhs: concatForM a b} + - warn: {lhs: fmap concat (forM_ a b), rhs: concatForM_ a b} + - warn: {lhs: concat <$> forM_ a b, rhs: concatForM_ a b} + - warn: {lhs: "maybe (pure ()) b a", rhs: "whenJust a b"} + - warn: {lhs: "maybe (return ()) b a", rhs: "whenJust a b"} + - warn: {lhs: "maybeM (pure ()) b a", rhs: "whenJustM a b"} + - warn: {lhs: "maybeM (return ()) b a", rhs: "whenJustM a b"} + - warn: {lhs: "if a then Just <$> b else pure Nothing", rhs: "whenMaybe a b"} + - warn: {lhs: "maybe a b =<< c", rhs: "maybeM a b c"} + - warn: {lhs: "maybeM a pure x", rhs: "fromMaybeM a b"} + - warn: {lhs: "maybeM a return x", rhs: "fromMaybeM a b"} + - warn: {lhs: "either a b =<< c", rhs: "eitherM a b c"} + - warn: {lhs: "fold1M a b >> return ()", rhs: "fold1M_ a b"} + - warn: {lhs: "fold1M a b >> pure ()", rhs: "fold1M_ a b"} + - warn: {lhs: "flip concatMapM", rhs: "concatForM"} + - warn: {lhs: "liftM mconcat (mapM a b)", rhs: "mconcatMapM a b"} + - warn: {lhs: "ifM a b (return ())", rhs: "whenM a b"} + - warn: {lhs: "ifM a (return ()) b", rhs: "unlessM a b"} + - warn: {lhs: "ifM a (return True) b", rhs: "(||^) a b"} + - warn: {lhs: "ifM a b (return False)", rhs: "(&&^) a b"} + - warn: {lhs: "anyM id", rhs: "orM"} + - warn: {lhs: "allM id", rhs: "andM"} + - warn: {lhs: "either id id", rhs: "fromEither"} + - warn: {lhs: "either (const Nothing) Just", rhs: "eitherToMaybe"} + - warn: {lhs: "either (Left . a) Right", rhs: "mapLeft a"} + - warn: {lhs: "atomicModifyIORef a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef_ a b"} + - warn: {lhs: "atomicModifyIORef' a (\\ v -> (b v, ()))", rhs: "atomicModifyIORef'_ a b"} + - warn: {lhs: "null (intersect a b)", rhs: "disjoint a b"} + - warn: {lhs: "[minBound .. maxBound]", rhs: "enumerate"} + - warn: {lhs: "zipWithFrom (,)", rhs: "zipFrom"} + - warn: {lhs: "zip [i..]", rhs: "zipFrom i"} + - warn: {lhs: "zipWith f [i..]", rhs: "zipWithFrom f i"} + - warn: {lhs: "dropWhile isSpace", rhs: "trimStart"} + - warn: {lhs: "dropWhileEnd isSpace", rhs: "trimEnd"} + - warn: {lhs: "trimEnd (trimStart a)", rhs: "trim a"} + - warn: {lhs: "map toLower", rhs: "lower"} + - warn: {lhs: "map toUpper", rhs: "upper"} + - warn: {lhs: "mergeBy compare", rhs: "merge"} + - warn: {lhs: "breakEnd (not . a)", rhs: "spanEnd a"} + - warn: {lhs: "spanEnd (not . a)", rhs: "breakEnd a"} + - warn: {lhs: "mconcat (map a b)", rhs: "mconcatMap a b"} + - warn: {lhs: "fromMaybe b (stripPrefix a b)", rhs: "dropPrefix a b"} + - warn: {lhs: "fromMaybe b (stripSuffix a b)", rhs: "dropSuffix a b"} + - warn: {lhs: "nubSortBy compare", rhs: "nubSort"} + - warn: {lhs: "nubSortBy (compare `on` a)", rhs: "nubSortOn a"} + - warn: {lhs: "nubOrdBy compare", rhs: "nubOrd"} + - warn: {lhs: "\\a -> (a, a)", rhs: "dupe"} + - warn: {lhs: "showFFloat (Just a) b \"\"", rhs: "showDP a b"} + - warn: {lhs: "readFileEncoding utf8", rhs: "readFileUTF8"} + - warn: {lhs: "withFile a ReadMode hGetContents'", rhs: "readFile' a"} + - warn: {lhs: "readFileEncoding' utf8", rhs: "readFileUTF8'"} + - warn: {lhs: "withBinaryFile a ReadMode hGetContents'", rhs: "readFileBinary' a"} + - warn: {lhs: "writeFileEncoding utf8", rhs: "writeFileUTF8"} + - warn: {lhs: "head $ x ++ [y]", rhs: "headDef y x"} + - warn: {lhs: "last $ x : y", rhs: "lastDef x y"} + - warn: {lhs: "drop 1", rhs: "drop1"} + - warn: {lhs: "dropEnd 1", rhs: "dropEnd1"} + +# hints that will be enabled in future +- group: + name: future + enabled: false + rules: + - warn: {lhs: return, rhs: pure} + +- group: name: dollar enabled: false imports: @@ -840,6 +938,18 @@ - warn: {lhs: a $ b $ c, rhs: a . b $ c} - group: + # These hints are same if all matched functions are monomorphic, or polymorphic, but don't have adhoc polymorphism + name: monomorphic + enabled: false + imports: + - package base + rules: + - warn: {lhs: if c then f x else f y, rhs: f (if c then x else y), note: IncreasesLaziness, name: Too strict if} + - hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe} + - hint: {lhs: maybe (f x) f y, rhs: f (Data.Maybe.fromMaybe x y), note: IncreasesLaziness, name: Too strict maybe} + + +- group: name: teaching enabled: false imports: @@ -927,6 +1037,7 @@ # yes = if p then s else return () -- Control.Monad.when p s # warn = a $$$$ b $$$$ c ==> a . b $$$$$ c # yes = when (not . null $ asdf) -- unless (null asdf) +# yes = (foo . bar . when) (not . null $ asdf) -- (foo . bar) (unless (null asdf)) # yes = id 1 -- 1 # yes = case concat (map f x) of [] -> [] -- concatMap f x # yes = [v | v <- xs] -- xs @@ -946,10 +1057,13 @@ # test = \ a -> f a >>= \ b -> return (a, b) # fooer input = catMaybes . map Just $ input -- mapMaybe Just # yes = mapMaybe id -- catMaybes +# foo = magic . isLeft $ fmap f x -- magic (isLeft x) +# foo = (bar . baz . magic . isRight) (fmap f x) -- (bar . baz . magic) (isRight x) # main = print $ map (\_->5) [2,3,5] -- const 5 # main = head $ drop n x -- x !! max 0 n # main = head $ drop (-3) x -- x # main = head $ drop 2 x -- x !! 2 +# main = foo . bar . baz . head $ drop 2 x -- (foo . bar . baz) (x !! 2) # main = drop 0 x -- x # main = take 0 x -- [] # main = take (-5) x -- [] @@ -959,7 +1073,8 @@ # main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l # main = fst (splitAt n l) -- take n l # main = snd $ splitAt n l -- drop n l -# main = map $ \ d -> ([| $d |], [| $d |]) +# main = map $ \ d -> ([| $d |], [| $d |]) @NoRefactor: apply-refact requires TemplateHaskell pragma +# {-# LANGUAGE TemplateHaskell #-}; main = map $ \ d -> ([| $d |], [| $d |]) # pairs (x:xs) = map (x,) xs ++ pairs xs # {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ??? # {-# HLINT ignore foo #-};foo = map f (map g x) -- @Ignore ??? @@ -1007,6 +1122,7 @@ # no = sequenceA (pure a) # {-# LANGUAGE QuasiQuotes #-}; no = f (\url -> [hamlet|foo @{url}|]) # yes = f ((,) x) -- (x,) +# yes = f ((,) (2 + 3)) -- (2 + 3,) # instance Class X where method = map f (map g x) -- map (f . g) x # instance Eq X where x == y = compare x y == EQ @@ -1045,4 +1161,11 @@ # foo = typeOf (undefined :: Foo Int) -- typeRep (Proxy :: Proxy (Foo Int)) # foo = typeOf (undefined :: a) -- typeRep (Proxy :: Proxy a) # {-# RULES "Id-fmap-id" forall (x :: Id a). fmap id x = x #-} +# import Data.Map (fromList) \ +# fromList [] -- Data.Map.empty +# import Data.Map.Lazy (fromList) \ +# fromList [] -- Data.Map.Lazy.empty +# import Data.Map.Strict (fromList) \ +# fromList [] -- Data.Map.Strict.empty +# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n} @NoRefactor # 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.11 +version: 3.0 license: BSD3 license-file: LICENSE category: Development @@ -27,7 +27,7 @@ extra-doc-files: README.md CHANGES.txt -tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4 +tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5 source-repository head type: git @@ -60,23 +60,23 @@ cpphs >= 1.20.1, cmdargs >= 0.10, yaml >= 0.5.0, - haskell-src-exts >= 1.21 && < 1.24, - haskell-src-exts-util >= 0.2.5, uniplate >= 1.5, ansi-terminal >= 0.6.2, - extra >= 1.6.6, + extra >= 1.7.1, refact >= 0.3, aeson >= 1.1.2.0, - filepattern >= 0.1.1, - ghc-lib-parser-ex == 8.8.5.* - if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) - build-depends: - ghc == 8.8.*, - ghc-boot-th, - ghc-boot + filepattern >= 0.1.1 + + if !flag(ghc-lib) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0) + build-depends: + ghc == 8.10.*, + ghc-boot-th, + ghc-boot else - build-depends: - ghc-lib-parser == 8.8.* + build-depends: + ghc-lib-parser == 8.10.* + build-depends: + ghc-lib-parser-ex >= 8.10.0.5 && < 8.10.1 if flag(gpl) build-depends: hscolour >= 1.21 @@ -86,13 +86,13 @@ hs-source-dirs: src exposed-modules: Language.Haskell.HLint - Language.Haskell.HLint3 - Language.Haskell.HLint4 other-modules: Paths_hlint Apply CmdLine Grep + Extension + Fixity HLint HsColour Idea @@ -116,9 +116,6 @@ 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 @@ -128,10 +125,6 @@ GHC.Util.Unify HSE.All - HSE.Match - HSE.Scope - HSE.Type - HSE.Util Hint.All Hint.Bracket Hint.Comment @@ -152,7 +145,6 @@ Hint.Smell Hint.Type Hint.Unsafe - Hint.Util Test.All Test.Annotations Test.InputOutput diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -6,6 +6,7 @@ import HSE.All import Hint.All import GHC.Util +import Data.Generics.Uniplate.Data import Idea import Data.Tuple.Extra import Data.Either @@ -14,7 +15,7 @@ import Data.Ord import Config.Type import Config.Haskell -import HsSyn +import GHC.Hs import qualified SrcLoc as GHC import qualified Data.HashSet as Set import Prelude @@ -24,7 +25,7 @@ applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea] applyHintFile flags s file src = do res <- parseModuleApply flags s file src - return $ case res of + pure $ case res of Left err -> [err] Right m -> executeHints s [m] @@ -33,7 +34,7 @@ applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] applyHintFiles flags s files = do (err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files - return $ err ++ executeHints s ms + pure $ err ++ executeHints s ms -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. @@ -48,32 +49,29 @@ applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] applyHintsReal settings hints_ ms = concat $ - [ 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 (maybeToList $ declName d) $ decHints' d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m] - | (nm, m) <- mns - , let classifiers = cls ++ mapMaybe readPragma (universeBi (hseModule m)) ++ concatMap readComment (ghcComments m) + [ map (classify classifiers . removeRequiresExtensionNotes m) $ + order [] (hintModule hints settings nm' m) `merge` + concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m] + | m <- ms + , let classifiers = cls ++ mapMaybe readPragma (universeBi (ghcModule m)) ++ concatMap readComment (ghcComments m) , seq (length classifiers) True -- to force any errors from readPragma or readComment - , let decHints = hintDecl hints settings nm m -- partially apply , (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 decHints = hintDecl hints settings nm' m' -- partially apply + , let order n = map (\i -> i{ideaModule = f $ modName (ghcModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn ideaSpan , let merge = mergeBy (comparing ideaSpan)] ++ - [map (classify cls) (hintModules hints settings mns)] + [map (classify cls) (hintModules hints settings mns')] where 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 + 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)]} -- If the hint has said you RequiresExtension Foo, but Foo is enabled, drop the note -removeRequiresExtensionNotes :: Module_ -> Idea -> Idea +removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x} where - exts = Set.fromList $ map fromNamed $ moduleExtensions m + exts = Set.fromList $ concatMap snd $ langExts $ pragmas $ ghcAnnotations m keep (RequiresExtension x) = not $ x `Set.member` exts keep _ = True @@ -87,11 +85,19 @@ parseModuleApply flags s file src = do res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src case res of - Right r -> return $ Right r + Right r -> pure $ Right r Left (ParseError sl msg ctxt) -> - return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing [] + pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing [] + where + -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works + -- try and tidy up things like "parse error (mismatched brackets)" to not look silly + adjustMessage :: String -> String + adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x) + dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs + dropBrackets xs = xs + -- | Find which hints a list of settings implies. allHints :: [Setting] -> Hint allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin @@ -101,10 +107,11 @@ -- | Given some settings, make sure the severity field of the Idea is correct. classify :: [Classify] -> Idea -> Idea -classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s} +classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s} where -- figure out if we need to change the severity f :: Idea -> Severity -> Classify -> Severity - f i r c | classifyHint c ~= [ideaHint i] && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c + f i r c | classifyHint c ~~= ideaHint i && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c | otherwise = r - x ~= y = null x || x `elem` y + x ~= y = x == "" || x `elem` y + x ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y) diff --git a/src/CC.hs b/src/CC.hs --- a/src/CC.hs +++ b/src/CC.hs @@ -13,13 +13,15 @@ import Data.Aeson (ToJSON(..), (.=), encode, object) import Data.Char (toUpper) import Data.Text (Text) -import Language.Haskell.Exts.SrcLoc (SrcSpan(..)) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as C8 import Idea (Idea(..), Severity(..)) +import qualified SrcLoc as GHC +import qualified GHC.Util as GHC + data Issue = Issue { issueType :: Text , issueCheckName :: Text @@ -119,11 +121,11 @@ points Warning = 5 * basePoints points Error = 10 * basePoints -fromSrcSpan :: SrcSpan -> Location -fromSrcSpan SrcSpan{..} = Location +fromSrcSpan :: GHC.SrcSpan -> Location +fromSrcSpan GHC.SrcSpan{..} = Location (locationFileName srcSpanFilename) - (Position srcSpanStartLine srcSpanStartColumn) - (Position srcSpanEndLine srcSpanEndColumn) + (Position srcSpanStartLine' srcSpanStartColumn) + (Position srcSpanEndLine' srcSpanEndColumn) where locationFileName ('.':'/':x) = x locationFileName x = x diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-} -{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-} +{-# OPTIONS_GHC -Wno-missing-fields -fno-cse -O0 #-} module CmdLine( Cmd(..), getCmd, @@ -8,14 +8,17 @@ ) where import Control.Monad.Extra +import Control.Exception.Extra import qualified Data.ByteString as BS import Data.Char -import Data.List +import Data.List.Extra import Data.Maybe import Data.Functor import HSE.All(CppFlags(..)) -import Language.Haskell.Exts(defaultParseMode, baseLanguage) -import Language.Haskell.Exts.Extension +import GHC.LanguageExtensions.Type +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx +import DynFlags hiding (verbosity) + import Language.Preprocessor.Cpphs import System.Console.ANSI(hSupportsANSI) import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) @@ -32,6 +35,7 @@ import EmbedData import Util +import Extension import Paths_hlint import Data.Version import Prelude @@ -47,29 +51,28 @@ CmdMain{} -> dataDir =<< path =<< git =<< extension cmd CmdGrep{} -> path =<< extension cmd CmdTest{} -> dataDir cmd - _ -> return cmd where - path cmd = return $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd - extension cmd = return $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd + path cmd = pure $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd + extension cmd = pure $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd dataDir cmd - | cmdDataDir cmd /= "" = return cmd + | cmdDataDir cmd /= "" = pure cmd | otherwise = do x <- getDataDir b <- doesDirectoryExist x - if b then return cmd{cmdDataDir=x} else do + if b then pure cmd{cmdDataDir=x} else do exe <- getExecutablePath - return cmd{cmdDataDir = takeDirectory exe "data"} + pure cmd{cmdDataDir = takeDirectory exe "data"} git cmd | cmdGit cmd = do mgit <- findExecutable "git" case mgit of - Nothing -> error "Could not find git" + Nothing -> errorIO "Could not find git" Just git -> do let args = ["ls-files", "--cached", "--others", "--exclude-standard"] ++ map ("*." ++) (cmdExtension cmd) files <- readProcess git args "" - return cmd{cmdFiles = cmdFiles cmd ++ lines files} - | otherwise = return cmd + pure cmd{cmdFiles = cmdFiles cmd ++ lines files} + | otherwise = pure cmd exitWithHelp :: IO a @@ -95,7 +98,6 @@ {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given ,cmdReports :: [FilePath] -- ^ where to generate reports ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given - ,cmdWithHints :: [String] -- ^ hints that are given on the command line ,cmdWithGroups :: [String] -- ^ groups that are given on the command line ,cmdGit :: Bool -- ^ use git ls-files to find files ,cmdColor :: ColorMode -- ^ color the result @@ -143,14 +145,10 @@ ,cmdGivenHints :: [FilePath] -- ^ which settings files were explicitly given ,cmdDataDir :: FilePath -- ^ the data directory ,cmdReports :: [FilePath] -- ^ where to generate reports - ,cmdWithHints :: [String] -- ^ hints that are given on the command line ,cmdTempDir :: FilePath -- ^ temporary directory to put the files in ,cmdQuickCheck :: Bool ,cmdTypeCheck :: Bool - } - | CmdHSE - {cmdFiles :: [FilePath] - ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No") + ,cmdWithRefactor :: FilePath } deriving (Data,Typeable,Show) @@ -159,7 +157,6 @@ {cmdFiles = def &= args &= typ "FILE/DIR" ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML" ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use" - ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use" ,cmdWithGroups = nam_ "with-group" &= typ "GROUP" &= help "Extra hint groups to use" ,cmdGit = nam "git" &= help "Run on files tracked by git" ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)" @@ -204,8 +201,6 @@ ,"" ,"To check all Haskell files in 'src' and generate a report type:" ," hlint src --report"] - ,CmdHSE - {} &= explicit &= name "hse" ] &= program "hlint" &= verbosity &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2020") where @@ -213,42 +208,40 @@ nam_ xs = def &= explicit &= name xs -- | Where should we find the configuration files? --- * If someone passes cmdWithHints, only look at files they explicitly request --- * If someone passes an explicit hint name, automatically merge in data/hlint.yaml +-- Either we use the implicit search, or we follow the cmdGivenHints -- We want more important hints to go last, since they override cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)] cmdHintFiles cmd = do - let explicit1 = [hlintYaml | null $ cmdWithHints cmd] - let explicit2 = cmdGivenHints cmd - bad <- filterM (notM . doesFileExist) explicit2 - let explicit2' = map (,Nothing) explicit2 + let explicit = cmdGivenHints cmd + bad <- filterM (notM . doesFileExist) explicit when (bad /= []) $ fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad - if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2' else do + + -- if the user has given any explicit hints, ignore the local ones + implicit <- if explicit /= [] then pure Nothing else do -- we follow the stylish-haskell config file search policy -- 1) current directory or its ancestors; 2) home directory curdir <- getCurrentDirectory -- Ignores home directory when it isn't present. - home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ return []) - implicit <- findM doesFileExist $ + home <- catchIOError ((:[]) <$> getHomeDirectory) (const $ pure []) + findM doesFileExist $ map ( ".hlint.yaml") (ancestors curdir ++ home) -- to match Stylish Haskell - ++ ["HLint.hs"] -- the default in HLint 1.* - return $ explicit1 ++ map (,Nothing) (maybeToList implicit) ++ explicit2' + pure $ hlintYaml : map (,Nothing) (maybeToList implicit ++ explicit) where ancestors = init . map joinPath . reverse . inits . splitPath -cmdExtensions :: Cmd -> (Language, [Extension]) +cmdExtensions :: Cmd -> (Maybe Language, [Extension]) cmdExtensions = getExtensions . cmdLanguage cmdCpp :: Cmd -> CppFlags cmdCpp cmd | cmdCppSimple cmd = CppSimple - | EnableExtension CPP `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions + | Cpp `elem` snd (cmdExtensions cmd) = Cpphs defaultCpphsOptions {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd} ,includes = cmdCppInclude cmd ,preInclude = cmdCppFile cmd - ,defines = ("__HLINT__","1") : [(a,drop 1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] + ,defines = ("__HLINT__","1") : [(a,drop1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] } | otherwise = NoCpp @@ -256,8 +249,8 @@ -- | Determines whether to use colour or not. cmdUseColour :: Cmd -> IO Bool cmdUseColour cmd = case cmdColor cmd of - Always -> return True - Never -> return False + Always -> pure True + Never -> pure False Auto -> hSupportsANSI stdout @@ -285,23 +278,23 @@ getFile :: (FilePath -> Bool) -> [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath] getFile _ path _ (Just tmpfile) "-" = -- make sure we don't reencode any Unicode - BS.getContents >>= BS.writeFile tmpfile >> return [tmpfile] -getFile _ path _ Nothing "-" = return ["-"] + BS.getContents >>= BS.writeFile tmpfile >> pure [tmpfile] +getFile _ path _ Nothing "-" = pure ["-"] getFile _ [] exts _ file = exitMessage $ "Couldn't find file: " ++ file getFile ignore (p:ath) exts t file = do isDir <- doesDirectoryExist $ p <\> file if isDir then do let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x - xs <- listFilesInside (return . not . avoidDir) $ p <\> file - return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x] + xs <- listFilesInside (pure . not . avoidDir) $ p <\> file + pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x] else do isFil <- doesFileExist $ p <\> file - if isFil then return [p <\> file] + if isFil then pure [p <\> file] else do res <- getModule p exts file case res of - Just x -> return [x] + Just x -> pure [x] Nothing -> getFile ignore ath exts t file @@ -313,28 +306,22 @@ isMod _ = False pre = path <\> joinPath xs - f [] = return Nothing + f [] = pure Nothing f (x:xs) = do let s = pre <.> x b <- doesFileExist s - if b then return $ Just s else f xs -getModule _ _ _ = return Nothing + if b then pure $ Just s else f xs +getModule _ _ _ = pure Nothing -getExtensions :: [String] -> (Language, [Extension]) -getExtensions args = (lang, foldl f (if null langs then parseExtensions else []) exts) +getExtensions :: [String] -> (Maybe Language, [Extension]) +getExtensions args = (lang, foldl f (if null langs then defaultExtensions else []) exts) where - lang = if null langs then baseLanguage defaultParseMode else fromJust $ lookup (last langs) ls + lang = if null langs then Nothing else Just $ fromJust $ lookup (last langs) ls (langs, exts) = partition (isJust . flip lookup ls) args - ls = [(show x, x) | x <- knownLanguages] + ls = [(show x, x) | x <- [Haskell98, Haskell2010]] f a "Haskell98" = [] - f a ('N':'o':x) | Just x <- readExtension x = delete x a - f a x | Just x <- readExtension x = x : delete x a - f a x = UnknownExtension x : delete (UnknownExtension x) a - - -readExtension :: String -> Maybe Extension -readExtension x = case classifyExtension x of - UnknownExtension _ -> Nothing - x -> Just x + f a ('N':'o':x) | Just x <- GhclibParserEx.readExtension x = delete x a + f a x | Just x <- GhclibParserEx.readExtension x = x : delete x a + f a x = a -- Ignore unknown extension. diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs --- a/src/Config/Compute.hs +++ b/src/Config/Compute.hs @@ -1,12 +1,21 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -- | Given a file, guess settings from it by looking at the hints. module Config.Compute(computeSettings) where import HSE.All +import GHC.Util import Config.Type -import Config.Haskell -import Data.Monoid +import Fixity +import Data.Generics.Uniplate.Data +import GHC.Hs hiding (Warning) +import RdrName +import Name +import Bag +import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances +import Language.Haskell.GhclibParserEx.GHC.Hs.Expr +import SrcLoc import Prelude @@ -17,46 +26,55 @@ x <- parseModuleEx flags file Nothing case x of Left (ParseError sl msg _) -> - return ("# Parse error " ++ showSrcLoc sl ++ ": " ++ msg, []) - Right (ModuleEx m _ _ _) -> do - let xs = concatMap (findSetting $ UnQual an) (moduleDecls m) - r = concatMap (readSetting mempty) xs - s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting r ++ ["# no hints found" | null xs] - return (s,r) + pure ("# Parse error " ++ showSrcSpan' sl ++ ": " ++ msg, []) + Right ModuleEx{ghcModule=m} -> do + let xs = concatMap findSetting (hsmodDecls $ unLoc m) + s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs] + pure (s,xs) + renderSetting :: Setting -> [String] +-- Only need to convert the subset of Setting we generate renderSetting (SettingMatchExp HintRule{..}) = - ["- warn: {lhs: " ++ show (prettyPrint hintRuleLHS) ++ ", rhs: " ++ show (prettyPrint hintRuleRHS) ++ "}"] -renderSetting (Infix x) = ["- infix: " ++ show (prettyPrint (toInfixDecl x))] + ["- warn: {lhs: " ++ show (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"] +renderSetting (Infix x) = + ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)] renderSetting _ = [] -findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_] -findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs] -findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod -findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind] -findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod -findSetting _ x@InfixDecl{} = [x] -findSetting _ _ = [] +findSetting :: LHsDecl GhcPs -> [Setting] +findSetting (L _ (ValD _ x)) = findBind x +findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) = + concatMap (findBind . unLoc) $ bagToList cid_binds +findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x +findSetting x = [] --- given a result function name, a list of variables, a body expression, give some hints -findExp :: QName S -> [String] -> Exp_ -> [Decl_] -findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod - | otherwise = [] - where ps2 = [x | PVar_ x <- map view ps] -findExp name vs Var{} = [] -findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") +findBind :: HsBind GhcPs -> [Setting] +findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs +findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches +findBind _ = [] -findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing] +findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting] +findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=L _ (EmptyLocalBinds _)}}]}) + = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else [] + where ps = [occNameString $ occName $ unLoc x | L _ (VarPat _ x) <- m_pats] +findExp name vs HsLam{} = [] +findExp name vs HsVar{} = [] +findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ + HsApp noExtField x $ noLoc $ HsPar noExtField $ noLoc $ HsApp noExtField y $ noLoc $ mkVar "_hlint" + +findExp name vs bod = [SettingMatchExp $ + HintRule Warning defaultHintName [] + mempty (extendInstances lhs) (extendInstances $ fromParen' rhs) Nothing] where - lhs = g $ transform f bod - rhs = apps $ Var an name : map snd rep + lhs = fromParen' $ noLoc $ transform f bod + rhs = apps' $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep - rep = zip vs $ map (toNamed . return) ['a'..] - f xx | Var_ x <- view xx, Just y <- lookup x rep = y - f (InfixApp _ x dol y) | isDol dol = App an x (paren y) + rep = zip vs $ map (mkVar . pure) ['a'..] + f (HsVar _ x) | Just y <- lookup (occNameString $ occName $ unLoc x) rep = y + f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ noLoc $ HsPar noExtField y f x = x - g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o - g o@App{} = o - g o = paren o + +mkVar :: String -> HsExpr GhcPs +mkVar = HsVar noExtField . noLoc . Unqual . mkVarOcc diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs --- a/src/Config/Haskell.hs +++ b/src/Config/Haskell.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Config.Haskell( readPragma, - readComment, - readSetting, - readFileConfigHaskell + readComment ) where -import HSE.All import Data.Char import Data.List.Extra import Text.Read.Extra(readMaybe) @@ -16,79 +13,38 @@ import Util import Prelude -import qualified HsSyn as GHC -import qualified BasicTypes as GHC import GHC.Util -import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import SrcLoc as GHC +import GHC.Hs.Extension +import GHC.Hs.Decls hiding (SpliceDecl) +import GHC.Hs.Expr hiding (Match) +import GHC.Hs.Lit +import FastString import ApiAnnotation - - -addInfix :: ParseFlags -> ParseFlags -addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"] - - ---------------------------------------------------------------------- --- READ A SETTINGS FILE - -readFileConfigHaskell :: FilePath -> Maybe String -> IO [Setting] -readFileConfigHaskell file contents = do - let flags = addInfix defaultParseFlags - res <- parseModuleEx flags file contents - case res of - Left (ParseError sl msg err) -> - error $ "Config parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err - Right modEx@(ModuleEx m _ _ _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment (ghcComments modEx)) - - --- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions. --- Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception. -readSettings :: Module_ -> [Setting] -readSettings m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $ - [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m - - -readSetting :: Scope -> Decl_ -> [Setting] -readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind]) - | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = - let (a,b) = readSide $ childrenBi bind in - 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. - (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing] - | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod] - where - names = filter (not . null) $ getNames pats bod - names2 = ["" | null names] ++ names - -readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = [] -readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y] -readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind] -readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs -readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] -readSetting s x@InfixDecl{} = map Infix $ getFixity x -readSetting s x = errorOn x "bad hint" +import OccName +import Outputable -- | Read an {-# ANN #-} pragma and determine if it is intended for HLint. -- Return Nothing if it is not an HLint pragma, otherwise what it means. -readPragma :: Annotation S -> Maybe Classify -readPragma o = case o of - Ann _ name x -> f (fromNamed name) x - TypeAnn _ name x -> f (fromNamed name) x - ModuleAnn _ x -> f "" x +readPragma :: AnnDecl GhcPs -> Maybe Classify +readPragma (HsAnnotation _ _ provenance expr) = f expr where - f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s = + name = case provenance of + ValueAnnProvenance (L _ x) -> occNameString $ occName x + TypeAnnProvenance (L _ x) -> occNameString $ occName x + ModuleAnnProvenance -> "" + + f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s = case getSeverity a of - Nothing -> errorOn o "bad classify pragma" + Nothing -> errorOn expr "bad classify pragma" Just severity -> Just $ Classify severity (trimStart b) "" name where (a,b) = break isSpace $ trimStart $ drop 6 s - f name (Paren _ x) = f name x - f name (ExpTypeSig _ x _) = f name x - f _ _ = Nothing - + f (L _ (HsPar _ x)) = f x + f (L _ (ExprWithTySig _ x _)) = f x + f _ = Nothing +readPragma _ = Nothing readComment :: GHC.Located AnnotationComment -> [Classify] readComment c@(L pos AnnBlockComment{}) @@ -117,60 +73,15 @@ readComment _ = [] -readSide :: [Decl_] -> (Maybe Exp_, [Note]) -readSide = foldl f (Nothing,[]) - where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes) - f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes) - f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note) - f _ x = errorOn x "bad side condition" - - g (Lit _ (String _ x _)) = [Note x] - g (List _ xs) = concatMap g xs - g x = case fromApps x of - [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness] - [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness] - [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a] - [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b] - [con -> Just "RequiresExtension",con -> Just a] -> [RequiresExtension a] - _ -> errorOn x "bad note" - - con :: Exp_ -> Maybe String - con c@Con{} = Just $ prettyPrint c; con _ = Nothing - var c@Var{} = Just $ prettyPrint c; var _ = Nothing - - --- Note: Foo may be ("","Foo") or ("Foo",""), return both -readFuncs :: Exp_ -> [(String, String)] -readFuncs (App _ x y) = readFuncs x ++ readFuncs y -readFuncs (Lit _ (String _ "" _)) = [("","")] -readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)] -readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)] -readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)] -readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] -readFuncs x = errorOn x "bad classification rule" - - -getNames :: [Pat_] -> Exp_ -> [String] -getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps -getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names - where - lnames = map f $ childrenS lhs - rnames = map f $ childrenS rhs - names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames - f (Ident _ x) = x - f (Symbol _ x) = x -getNames _ _ = [] - - -errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b -errorOn val msg = exitMessageImpure $ - showSrcLoc (getPointLoc $ ann val) ++ +errorOn :: Outputable a => Located a -> String -> b +errorOn (L pos val) msg = exitMessageImpure $ + showSrcSpan' pos ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ - prettyPrint val + unsafePrettyPrint val errorOnComment :: GHC.Located AnnotationComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $ let isMultiline = isCommentMultiline c in - showSrcLoc (ghcSrcLocToHSE $ GHC.srcSpanStart s) ++ + showSrcSpan' s ++ ": Error while reading hint file, " ++ msg ++ "\n" ++ (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "") diff --git a/src/Config/Read.hs b/src/Config/Read.hs --- a/src/Config/Read.hs +++ b/src/Config/Read.hs @@ -2,7 +2,8 @@ module Config.Read(readFilesConfig) where import Config.Type -import Config.Haskell +import Control.Monad +import Control.Exception.Extra import Config.Yaml import Data.List.Extra import System.FilePath @@ -10,8 +11,11 @@ readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting] readFilesConfig files = do - yaml <- mapM (uncurry readFileConfigYaml) yaml - haskell <- mapM (uncurry readFileConfigHaskell) haskell - return $ concat haskell ++ settingsFromConfigYaml yaml - where - (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files + let (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files + unless (null haskell) $ + errorIO $ "HLint 2.3 and beyond cannot use Haskell configuration files.\n" ++ + "Tried to use: " ++ show haskell ++ "\n" ++ + "Convert it to .yaml file format, following the example at\n" ++ + " " + yaml <- mapM (uncurry readFileConfigYaml) yaml + pure $ settingsFromConfigYaml yaml diff --git a/src/Config/Type.hs b/src/Config/Type.hs --- a/src/Config/Type.hs +++ b/src/Config/Type.hs @@ -5,12 +5,13 @@ defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType ) where -import HSE.All import Data.Char import Data.List.Extra import Prelude -import qualified HsSyn + +import qualified GHC.Hs +import Fixity import GHC.Util import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances @@ -40,7 +41,7 @@ = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas). | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not. | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply. - | Error -- ^ Available as a setting for the user. + | Error -- ^ Available as a setting for the user. Only parse errors have this setting by default. deriving (Eq,Ord,Show,Read,Bounded,Enum) @@ -94,16 +95,12 @@ data HintRule = HintRule {hintRuleSeverity :: Severity -- ^ Default severity for the hint. ,hintRuleName :: String -- ^ Name for the hint. - ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates. - ,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS - ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS - ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@. ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint. + ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates (GHC parse tree). -- We wrap these GHC elements in 'HsExtendInstances' in order that we may derive 'Show'. - ,hintRuleGhcScope :: HsExtendInstances Scope' -- ^ Module scope in which the hint operates (GHC parse tree). - ,hintRuleGhcLHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree). - ,hintRuleGhcRHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree). - ,hintRuleGhcSide :: Maybe (HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs)) -- ^ Side condition (GHC parse tree). + ,hintRuleLHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ LHS (GHC parse tree). + ,hintRuleRHS :: HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs) -- ^ RHS (GHC parse tree). + ,hintRuleSide :: Maybe (HsExtendInstances (GHC.Hs.LHsExpr GHC.Hs.GhcPs)) -- ^ Side condition (GHC parse tree). } deriving Show @@ -136,5 +133,5 @@ | SettingArgument String -- ^ Extra command-line argument | SettingSmell SmellType Int | Builtin String -- use a builtin hint set - | Infix Fixity + | Infix FixityInfo deriving Show diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-} module Config.Yaml( @@ -18,30 +19,39 @@ import qualified Data.Vector as V import qualified Data.ByteString.Char8 as BS import qualified Data.HashMap.Strict as Map -import HSE.All hiding (Rule, String) +import Data.Generics.Uniplate.Data +import HSE.All +import Fixity +import Extension +import Module import Data.Functor import Data.Semigroup import Timing -import Util import Prelude +import Bag import qualified Lexer as GHC import qualified ErrUtils import qualified Outputable -import qualified HsSyn -import GHC.Util (baseDynFlags, Scope',scopeCreate') +import GHC.Hs +import SrcLoc +import qualified RdrName as GHC +import qualified OccName as GHC +import GHC.Util (baseDynFlags, Scope,scopeCreate) import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances +import Data.Char + -- | Read a config file in YAML format. Takes a filename, and optionally the contents. -- Fails if the YAML doesn't parse or isn't valid HLint YAML readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml readFileConfigYaml file contents = timedIO "Config" file $ do val <- case contents of Nothing -> decodeFileEither file - Just src -> return $ decodeEither' $ BS.pack src + Just src -> pure $ decodeEither' $ BS.pack src case val of Left e -> fail $ "Failed to read YAML configuration file " ++ file ++ "\n " ++ displayException e - Right v -> return v + Right v -> pure v --------------------------------------------------------------------- @@ -57,15 +67,13 @@ data Package = Package {packageName :: String - ,packageModules :: [ImportDecl S] - ,packageGhcModules :: [HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs)] + ,packageModules :: [HsExtendInstances (LImportDecl GhcPs)] } deriving Show data Group = Group {groupName :: String ,groupEnabled :: Bool - ,groupImports :: [Either String (ImportDecl S)] -- Left for package imports - ,groupGhcImports :: [Either String (HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs))] + ,groupImports :: [Either String (HsExtendInstances (LImportDecl GhcPs))] ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty } deriving Show @@ -99,11 +107,11 @@ dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...") parseArray :: Val -> Parser [Val] -parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWith (\i x -> addVal (show i) x v) [0..] $ V.toList xs -parseArray v = return [v] +parseArray v@(getVal -> Array xs) = concatMapM parseArray $ zipWithFrom (\i x -> addVal (show i) x v) 0 $ V.toList xs +parseArray v = pure [v] parseObject :: Val -> Parser (Map.HashMap T.Text Value) -parseObject (getVal -> Object x) = return x +parseObject (getVal -> Object x) = pure x parseObject v = parseFail v "Expected an Object" parseObject1 :: Val -> Parser (String, Val) @@ -114,7 +122,7 @@ _ -> parseFail v $ "Expected exactly one key but got " ++ show (Map.size mp) parseString :: Val -> Parser String -parseString (getVal -> String x) = return $ T.unpack x +parseString (getVal -> String x) = pure $ T.unpack x parseString v = parseFail v "Expected a String" parseInt :: Val -> Parser Int @@ -125,11 +133,11 @@ parseArrayString = parseArray >=> mapM parseString maybeParse :: (Val -> Parser a) -> Maybe Val -> Parser (Maybe a) -maybeParse parseValue Nothing = return Nothing +maybeParse parseValue Nothing = pure Nothing maybeParse parseValue (Just value) = Just <$> parseValue value parseBool :: Val -> Parser Bool -parseBool (getVal -> Bool b) = return b +parseBool (getVal -> Bool b) = pure b parseBool v = parseFail v "Expected a Bool" parseField :: String -> Val -> Parser Val @@ -137,14 +145,14 @@ x <- parseFieldOpt s v case x of Nothing -> parseFail v $ "Expected a field named " ++ s - Just v -> return v + Just v -> pure v parseFieldOpt :: String -> Val -> Parser (Maybe Val) parseFieldOpt s v = do mp <- parseObject v case Map.lookup (T.pack s) mp of - Nothing -> return Nothing - Just x -> return $ Just $ addVal s x v + Nothing -> pure Nothing + Just x -> pure $ Just $ addVal s x v allowFields :: Val -> [String] -> Parser () allowFields v allow = do @@ -153,29 +161,22 @@ when (bad /= []) $ parseFail v $ "Not allowed keys: " ++ unwords bad -parseHSE :: (ParseMode -> String -> ParseResult v) -> Val -> Parser v -parseHSE parser v = do - 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 - -parseGHC :: (ParseMode -> String -> GHC.ParseResult v) -> Val -> Parser v +parseGHC :: (ParseFlags -> 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) + case parser defaultParseFlags{extensions=configExtensions} x of + GHC.POk _ x -> pure x + GHC.PFailed ps -> + let (_, errs) = GHC.getMessages ps baseDynFlags + errMsg = head (bagToList errs) + msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x --------------------------------------------------------------------- -- YAML TO DATA TYPE instance FromJSON ConfigYaml where - parseJSON Null = return mempty + parseJSON Null = pure mempty parseJSON x = parseConfigYaml $ newVal x parseConfigYaml :: Val -> Parser ConfigYaml @@ -197,15 +198,14 @@ parsePackage :: Val -> Parser Package parsePackage v = do packageName <- parseField "name" v >>= parseString - packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode) - packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode) + packageModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode) allowFields v ["name","modules"] - return Package{..} + pure Package{..} parseFixity :: Val -> Parser [Setting] -parseFixity v = parseArray v >>= concatMapM (parseHSE parseDeclWithMode >=> f) +parseFixity v = parseArray v >>= concatMapM (parseGHC parseDeclGhcWithMode >=> f) where - f x@InfixDecl{} = return $ map Infix $ getFixity x + f (L _ (SigD _ (FixSig _ x))) = pure $ map Infix $ fromFixitySig x f _ = parseFail v "Expected fixity declaration" parseSmell :: Val -> Parser [Setting] @@ -213,59 +213,48 @@ smellName <- parseField "type" v >>= parseString smellType <- require v "Expected SmellType" $ getSmellType smellName smellLimit <- parseField "limit" v >>= parseInt - return [SettingSmell smellType smellLimit] + pure [SettingSmell smellType smellLimit] where require :: Val -> String -> Maybe a -> Parser a - require _ _ (Just a) = return a + require _ _ (Just a) = pure a require val err Nothing = parseFail val err parseGroup :: Val -> Parser Group parseGroup v = do 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 + groupEnabled <- parseFieldOpt "enabled" v >>= maybe (pure True) parseBool + groupImports <- parseFieldOpt "imports" v >>= maybe (pure []) (parseArray >=> mapM parseImport) + groupRules <- parseFieldOpt "rules" v >>= maybe (pure []) parseArray >>= concatMapM parseRule allowFields v ["name","enabled","imports","rules"] - return Group{..} + pure Group{..} where parseImport v = do x <- parseString v case word1 x of - ("package", x) -> return $ Left x - _ -> Right <$> parseHSE parseImportDeclWithMode v - parseImportGHC v = do - x <- parseString v - case word1 x of - ("package", x) -> return $ Left x + ("package", x) -> pure $ Left x _ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v ruleToGroup :: [Either HintRule Classify] -> Group -ruleToGroup = Group "" True [] [] +ruleToGroup = Group "" True [] parseRule :: Val -> Parser [Either HintRule Classify] parseRule v = do (severity, v) <- parseSeverityKey v isRule <- isJust <$> parseFieldOpt "lhs" v if isRule then do - hintRuleLHS <- parseField "lhs" v >>= parseHSE parseExpWithMode - hintRuleRHS <- parseField "rhs" v >>= parseHSE parseExpWithMode - hintRuleNotes <- parseFieldOpt "note" v >>= maybe (return []) (fmap (map asNote) . parseArrayString) - hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString - hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode) - - hintRuleGhcLHS <- parseField "lhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode - hintRuleGhcRHS <- parseField "rhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode - hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode) + hintRuleNotes <- parseFieldOpt "note" v >>= maybe (pure []) (fmap (map asNote) . parseArrayString) + lhs <- parseField "lhs" v >>= parseGHC parseExpGhcWithMode + rhs <- parseField "rhs" v >>= parseGHC parseExpGhcWithMode + hintRuleSide <- parseFieldOpt "side" v >>= maybe (pure Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode) + hintRuleName <- parseFieldOpt "name" v >>= maybe (pure $ guessName lhs rhs) parseString allowFields v ["lhs","rhs","note","name","side"] - let hintRuleScope = mempty :: Scope - let hintRuleGhcScope = extendInstances mempty :: HsExtendInstances Scope' - return [Left HintRule{hintRuleSeverity=severity, ..}] + let hintRuleScope = mempty + pure [Left HintRule{hintRuleSeverity=severity,hintRuleLHS=extendInstances lhs,hintRuleRHS=extendInstances rhs, ..}] else do - names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString - within <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin) - return [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names] + names <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString + within <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin) + pure [Right $ Classify severity n a b | (a,b) <- within, n <- ["" | null names] ++ names] parseRestrict :: RestrictType -> Val -> Parser Restrict parseRestrict restrictType v = do @@ -274,42 +263,44 @@ Just def -> do b <- parseBool def allowFields v ["default"] - return $ Restrict restrictType b [] [] [] [] Nothing + pure $ 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 + restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString + restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin) + restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"] - return Restrict{restrictDefault=True,..} + pure Restrict{restrictDefault=True,..} parseWithin :: Val -> Parser [(String, String)] -- (module, decl) parseWithin v = do - x <- parseHSE parseExpWithMode v + x <- parseGHC parseExpGhcWithMode v case x of - Var _ (UnQual _ name) -> return [("",fromNamed name)] - Var _ (Qual _ (ModuleName _ mod) name) -> return [(mod, fromNamed name)] - Con _ (UnQual _ name) -> return [(fromNamed name,""),("",fromNamed name)] - Con _ (Qual _ (ModuleName _ mod) name) -> return [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] + L _ (HsVar _ (L _ (GHC.Unqual x))) -> pure $ f "" (GHC.occNameString x) + L _ (HsVar _ (L _ (GHC.Qual mod x))) -> pure $ f (moduleNameString mod) (GHC.occNameString x) _ -> parseFail v "Bad classification rule" + where + f mod name@(c:_) | isUpper c = [(mod,name),(mod ++ ['.' | mod /= ""] ++ name, "")] + f mod name = [(mod, name)] parseSeverityKey :: Val -> Parser (Severity, Val) parseSeverityKey v = do (s, v) <- parseObject1 v case getSeverity s of - Just sev -> return (sev, v) + Just sev -> pure (sev, v) _ -> parseFail v $ "Key should be a severity (e.g. warn/error/suggest) but got " ++ s -guessName :: Exp_ -> Exp_ -> String +guessName :: LHsExpr GhcPs -> LHsExpr GhcPs -> String guessName lhs rhs | n:_ <- rs \\ ls = "Use " ++ n | n:_ <- ls \\ rs = "Redundant " ++ n | otherwise = defaultHintName where (ls, rs) = both f (lhs, rhs) - f = filter (not . isUnifyVar) . map (\x -> fromNamed (x :: Name S)) . childrenS + f :: LHsExpr GhcPs -> [String] + f x = [y | L _ (HsVar _ (L _ x)) <- universe x, let y = GHC.occNameString $ GHC.rdrNameOcc x, not $ isUnifyVar y, y /= "."] asNote :: String -> Note @@ -330,26 +321,17 @@ packages = [x | ConfigPackage x <- configs] groups = [x | ConfigGroup x <- configs] settings = concat [x | ConfigSetting x <- configs] - packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages] - packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageGhcModules) | Package{..} <- packages] + packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageModules) | Package{..} <- packages] groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups] f Group{..} | Map.lookup groupName groupMap == Just False = [] - | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope,hintRuleGhcScope=scope'}) SettingClassify) groupRules + | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope'}) SettingClassify) groupRules where - scope = asScope packageMap groupImports - scope'= asScope' packageMap' (map (fmap unextendInstances) groupGhcImports) - -asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope -asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) [] - where - f (Right x) = [x] - f (Left x) | Just pkg <- Map.lookup x packages = pkg - | otherwise = error $ "asScope failed to do lookup, " ++ x + scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) -asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> HsExtendInstances Scope' -asScope' packages xs = HsExtendInstances $ scopeCreate' (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing) +asScope' :: Map.HashMap String [LImportDecl GhcPs] -> [Either String (LImportDecl GhcPs)] -> Scope +asScope' packages xs = scopeCreate (HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing) where f (Right x) = [x] f (Left x) | Just pkg <- Map.lookup x packages = pkg diff --git a/src/Extension.hs b/src/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Extension.hs @@ -0,0 +1,61 @@ +module Extension( + defaultExtensions, + configExtensions, + extensionImpliedEnabledBy, + extensionImplies + ) where + +import Data.List.Extra +import qualified Data.Map as Map +import GHC.LanguageExtensions.Type +import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx + +badExtensions = + reallyBadExtensions ++ + [ Arrows -- steals proc + , UnboxedTuples, UnboxedSums -- breaks (#) lens operator + , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + , {- DoRec , -} RecursiveDo -- breaks rec + , TypeApplications -- HSE fails on @ patterns + ] + +reallyBadExtensions = + [ TransformListComp -- steals the group keyword + , StaticPointers -- steals the static keyword + {- , XmlSyntax , RegularPatterns -} -- steals a-b and < operators + , AlternativeLayoutRule -- Does not play well with 'MultiWayIf' + , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests. + ] + +-- | Extensions we turn on by default when parsing. Aim to parse as +-- many files as we can. +defaultExtensions :: [Extension] +defaultExtensions = enumerate \\ badExtensions + +-- | Extensions we turn on when reading config files, don't have to deal with the whole world +-- of variations - in particular, we might require spaces in some places. +configExtensions :: [Extension] +configExtensions = enumerate \\ reallyBadExtensions + +-- | This extension implies the following extensions are +-- enabled/disabled. +extensionImplies :: Extension -> ([Extension], [Extension]) +extensionImplies = \x ->Map.findWithDefault ([], []) x mp + where mp = Map.fromList extensionImplications + +-- 'x' is implied enabled by the result extensions. +extensionImpliedEnabledBy :: Extension -> [Extension] +extensionImpliedEnabledBy = \x -> Map.findWithDefault [] x mp + where + mp = Map.fromListWith (++) [(b, [a]) | (a, (bs, _)) <- extensionImplications, b <- bs] + +-- 'x' is implied disabled by the result extensions. Not called at this time. +_extensionImpliedDisabledBy :: Extension -> [Extension] +_extensionImpliedDisabledBy = \x -> Map.findWithDefault [] x mp + where + mp = Map.fromListWith (++) [(b, [a]) | (a, (_, bs)) <- extensionImplications, b <- bs] + +-- | (a, bs) means extension a implies all of bs. Uses GHC source at +-- DynFlags.impliedXFlags +extensionImplications :: [(Extension, ([Extension], [Extension]))] +extensionImplications = GhclibParserEx.extensionImplications diff --git a/src/Fixity.hs b/src/Fixity.hs new file mode 100644 --- /dev/null +++ b/src/Fixity.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE ViewPatterns #-} + +module Fixity( + FixityInfo, Associativity(..), + defaultFixities, + fromFixitySig, toFixitySig, toFixity, + ) where + +import GHC.Generics(Associativity(..)) +import GHC.Hs.Binds +import GHC.Hs.Extension +import OccName +import RdrName +import SrcLoc +import BasicTypes +import Language.Haskell.GhclibParserEx.Fixity + +-- Lots of things define a fixity. None define it quite right, so let's have our own type. + +-- | A Fixity definition, comprising the name the fixity applies to, +-- the direction and the precedence. As an example, a source file containing: +-- +-- > infixr 3 `foo` +-- +-- would create @(\"foo\", RightAssociative, 3)@. +type FixityInfo = (String, Associativity, Int) + +fromFixitySig :: FixitySig GhcPs -> [FixityInfo] +fromFixitySig (FixitySig _ names (Fixity _ i dir)) = + [(occNameString $ occName $ unLoc name, f dir, i) | name <- names] + where + f InfixL = LeftAssociative + f InfixR = RightAssociative + f InfixN = NotAssociative +fromFixitySig _ = [] + +toFixity :: FixityInfo -> (String, Fixity) +toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir) + where + f LeftAssociative = InfixL + f RightAssociative = InfixR + f NotAssociative = InfixN + +fromFixity :: (String, Fixity) -> FixityInfo +fromFixity (name, Fixity _ i dir) = (name, assoc dir, i) + where + assoc dir = case dir of + InfixL -> LeftAssociative + InfixR -> RightAssociative + InfixN -> NotAssociative + +toFixitySig :: FixityInfo -> FixitySig GhcPs +toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLoc $ mkRdrUnqual (mkVarOcc name)] x + +defaultFixities :: [FixityInfo] +defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities + +-- List as provided at https://github.com/ndmitchell/hlint/issues/416. +lensFixities :: [(String, Fixity)] +lensFixities = concat + [ infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","","??"] + , infixl_ 8 ["^.","^@."] + , infixr_ 9 ["<.>","<.",".>"] + , infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"] + , infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="] + , infixr_ 2 ["<~"] + , infixr_ 2 ["`zoom`","`magnify`"] + , infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"] + , infixl_ 8 ["^#"] + , infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"] + , infix_ 4 ["<#=","#=","#%=","<#%=","#%%="] + , infixl_ 9 [":>"] + , infixr_ 4 ["~","<~","<.>~","<<.>~"] + , infix_ 4 ["=","<=","<.>=","<<.>="] + , infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"] + , infix_ 4 [".|.=",".&.=","<.|.=","<.&.="] + ] + +otherFixities :: [(String, Fixity)] +otherFixities = concat + -- hspec + [ infix_ 1 ["shouldBe","shouldSatisfy","shouldStartWith","shouldEndWith","shouldContain","shouldMatchList" + ,"shouldReturn","shouldNotBe","shouldNotSatisfy","shouldNotContain","shouldNotReturn","shouldThrow"] + -- quickcheck + , infixr_ 0 ["==>"] + , infix_ 4 ["==="] + -- esqueleto + , infix_ 4 ["==."] + -- lattices + , infixr_ 5 ["\\/"] -- \/ + , infixr_ 6 ["/\\"] -- /\ + ] + +customFixities :: [(String, Fixity)] +customFixities = + infixl_ 1 ["`on`"] + -- See https://github.com/ndmitchell/hlint/issues/425 + -- otherwise GTK apps using `on` at a different fixity have + -- spurious warnings. diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs --- a/src/GHC/Util.hs +++ b/src/GHC/Util.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Util ( module GHC.Util.View @@ -5,9 +7,6 @@ , 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 @@ -17,17 +16,17 @@ , module GHC.Util.Unify , parsePragmasIntoDynFlags - , parseFileGhcLib, parseExpGhcLib, parseImportGhcLib + , parseFileGhcLib, parseExpGhcLib, parseImportGhcLib, parseDeclGhcLib + , pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn + , pattern SrcLoc, srcFilename, srcLine, srcColumn + , showSrcSpan', ) where import GHC.Util.View import GHC.Util.FreeVars import GHC.Util.ApiAnnotation import GHC.Util.HsExpr -import GHC.Util.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 @@ -36,13 +35,14 @@ import GHC.Util.Scope import GHC.Util.Unify -import qualified Language.Haskell.GhclibParserEx.Parse as GhclibParserEx -import Language.Haskell.GhclibParserEx.DynFlags (parsePragmasIntoDynFlags) +import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GhclibParserEx +import Language.Haskell.GhclibParserEx.GHC.Driver.Session (parsePragmasIntoDynFlags) -import HsSyn +import GHC.Hs import Lexer import SrcLoc import DynFlags +import FastString import System.FilePath import Language.Preprocessor.Unlit @@ -53,7 +53,76 @@ parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) parseImportGhcLib = GhclibParserEx.parseImport +parseDeclGhcLib :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) +parseDeclGhcLib = GhclibParserEx.parseDeclaration + parseFileGhcLib :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) parseFileGhcLib filename str flags = GhclibParserEx.parseFile filename flags (if takeExtension filename /= ".lhs" then str else unlit filename str) + +{-# COMPLETE SrcSpan #-} +-- | The \"Line'\" thing is because there is already e.g. 'SrcLoc.srcSpanStartLine' +pattern SrcSpan :: String -> Int -> Int -> Int -> Int -> SrcSpan +pattern SrcSpan + { srcSpanFilename + , srcSpanStartLine' + , srcSpanStartColumn + , srcSpanEndLine' + , srcSpanEndColumn + } + <- + (toOldeSpan -> + ( srcSpanFilename + , srcSpanStartLine' + , srcSpanStartColumn + , srcSpanEndLine' + , srcSpanEndColumn + )) + +toOldeSpan :: SrcSpan -> (String, Int, Int, Int, Int) +toOldeSpan (RealSrcSpan span) = + ( unpackFS $ srcSpanFile span + , srcSpanStartLine span + , srcSpanStartCol span + , srcSpanEndLine span + , srcSpanEndCol span + ) +-- TODO: the bad locations are all (-1) right now +-- is this fine? it should be, since noLoc from HSE previously also used (-1) as an invalid location +toOldeSpan (UnhelpfulSpan str) = + ( unpackFS str + , -1 + , -1 + , -1 + , -1 + ) + +{-# COMPLETE SrcLoc #-} +pattern SrcLoc :: String -> Int -> Int -> SrcLoc +pattern SrcLoc + { srcFilename + , srcLine + , srcColumn + } + <- + (toOldeLoc -> + ( srcFilename + , srcLine + , srcColumn + )) + +toOldeLoc :: SrcLoc -> (String, Int, Int) +toOldeLoc (RealSrcLoc loc) = + ( unpackFS $ srcLocFile loc + , srcLocLine loc + , srcLocCol loc + ) +toOldeLoc (UnhelpfulLoc str) = + ( unpackFS str + , -1 + , -1 + ) + +showSrcSpan' :: SrcSpan -> String +showSrcSpan' = unsafePrettyPrint diff --git a/src/GHC/Util/ApiAnnotation.hs b/src/GHC/Util/ApiAnnotation.hs --- a/src/GHC/Util/ApiAnnotation.hs +++ b/src/GHC/Util/ApiAnnotation.hs @@ -96,8 +96,8 @@ -- 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 ++ " #-}") + L loc $ AnnBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}") mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment mkLangExts loc exts = - LL loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}") + L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}") diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs --- a/src/GHC/Util/Brackets.hs +++ b/src/GHC/Util/Brackets.hs @@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-} + module GHC.Util.Brackets (Brackets'(..), isApp,isOpApp,isAnyApp) where -import HsSyn +import GHC.Hs import SrcLoc import BasicTypes import Language.Haskell.GhclibParserEx.GHC.Hs.Expr @@ -22,14 +24,14 @@ -- 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' (L _ (HsPar _ (L _ SectionL{}))) = Nothing + remParen' (L _ (HsPar _ (L _ SectionR{}))) = Nothing + remParen' (L _ (HsPar _ x)) = Just x remParen' _ = Nothing - addParen' e = noLoc $ HsPar noExt e + addParen' e = noLoc $ HsPar noExtField e - isAtom' (LL _ x) = case x of + isAtom' (L _ x) = case x of HsVar{} -> True HsUnboundVar{} -> True HsRecFld{} -> True @@ -60,33 +62,36 @@ isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f isNegativeOverLit _ = False - isAtom' _ = False -- '{-# COMPLETE LL #-}' + isAtom' _ = False -- '{-# COMPLETE L #-}' 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 + | isSection parent, L _ HsApp{} <- child = False + | L _ OpApp{} <- parent, L _ HsApp{} <- child = False + | L _ ExplicitList{} <- parent = False + | L _ ExplicitTuple{} <- parent = False + | L _ HsIf{} <- parent, isAnyApp child = False + | L _ HsApp{} <- parent, i == 0, L _ HsApp{} <- child = False + | L _ ExprWithTySig{} <- parent, i == 0, isApp child = False + | L _ RecordCon{} <- parent = False + | L _ RecordUpd{} <- parent, i /= 0 = False + + -- These all have view patterns embedded within them, or are naturally followed by ->, so we have to watch out for + -- @(x::y) -> z@ which is valid, as either a type annotation, or a view pattern. + | L _ HsLet{} <- parent, isApp child = False + | L _ HsDo{} <- parent, isAnyApp child = False + | L _ HsLam{} <- parent, isAnyApp child = False + | L _ HsCase{} <- parent, isAnyApp child = False + + | L _ HsPar{} <- parent = False | otherwise = True -instance Brackets' (Pat GhcPs) where - remParen' (LL _ (ParPat _ x)) = Just x +instance Brackets' (Located (Pat GhcPs)) where + remParen' (L _ (ParPat _ x)) = Just x remParen' _ = Nothing - addParen' e = noLoc $ ParPat noExt e + addParen' e = noLoc $ ParPat noExtField e - isAtom' (LL _ x) = case x of + isAtom' (L _ x) = case x of ParPat{} -> True TuplePat{} -> True ListPat{} -> True @@ -108,20 +113,20 @@ isSignedLit HsFloatPrim{} = True isSignedLit HsDoublePrim{} = True isSignedLit _ = False - isAtom' _ = False -- '{-# COMPLETE LL #-}' + isAtom' _ = False -- '{-# COMPLETE L #-}' needBracket' _ parent child | isAtom' child = False - | LL _ TuplePat{} <- parent = False - | LL _ ListPat{} <- parent = False + | L _ TuplePat{} <- parent = False + | L _ ListPat{} <- parent = False | otherwise = True instance Brackets' (LHsType GhcPs) where - remParen' (LL _ (HsParTy _ x)) = Just x + remParen' (L _ (HsParTy _ x)) = Just x remParen' _ = Nothing - addParen' e = noLoc $ HsParTy noExt e + addParen' e = noLoc $ HsParTy noExtField e - isAtom' (LL _ x) = case x of + isAtom' (L _ x) = case x of HsParTy{} -> True HsTupleTy{} -> True HsListTy{} -> True @@ -132,18 +137,18 @@ HsSpliceTy{} -> True HsWildCardTy{} -> True _ -> False - isAtom' _ = False -- '{-# COMPLETE LL #-}' + isAtom' _ = False -- '{-# COMPLETE L #-}' needBracket' _ parent child | isAtom' child = False -- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc. -- | TyFun{} <- parent, i == 1, TyFun{} <- child = False - | 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 + | L _ HsFunTy{} <- parent, L _ HsAppTy{} <- child = False + | L _ HsTupleTy{} <- parent = False + | L _ HsListTy{} <- parent = False + | L _ HsExplicitTupleTy{} <- parent = False + | L _ HsListTy{} <- parent = False + | L _ HsExplicitListTy{} <- parent = False + | L _ HsOpTy{} <- parent, L _ HsAppTy{} <- child = False + | L _ HsParTy{} <- parent = False | otherwise = True diff --git a/src/GHC/Util/DynFlags.hs b/src/GHC/Util/DynFlags.hs --- a/src/GHC/Util/DynFlags.hs +++ b/src/GHC/Util/DynFlags.hs @@ -1,4 +1,4 @@ -module GHC.Util.DynFlags (baseDynFlags) where +module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where import DynFlags import GHC.LanguageExtensions.Type @@ -17,3 +17,7 @@ -- hlint.yaml:860 let enable = [TemplateHaskellQuotes] in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable + + +initGlobalDynFlags :: IO () +initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs --- a/src/GHC/Util/FreeVars.hs +++ b/src/GHC/Util/FreeVars.hs @@ -1,19 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module GHC.Util.FreeVars ( - vars', varss', pvars', freeVarSet' - , Vars' (..), FreeVars'(..) , AllVars' (..) + vars', varss', pvars', + Vars' (..), FreeVars'(..) , AllVars' (..) ) where import RdrName -import HsTypes +import GHC.Hs.Types import OccName import Name -import HsSyn +import GHC.Hs import SrcLoc import Bag (bagToList) @@ -21,6 +19,7 @@ import Data.Generics.Uniplate.Operations import Data.Monoid import Data.Semigroup +import Data.List.Extra import Data.Set (Set) import qualified Data.Set as Set import Prelude @@ -69,7 +68,7 @@ -- ================================== -- 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 (AllVars' a) => AllVars' [a] where allVars' = mconcatMap allVars' instance (FreeVars' a) => FreeVars' [a] where freeVars' = Set.unions . map freeVars' -- Construct a `Vars` value with no bound vars. @@ -94,79 +93,83 @@ -- 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' (L _ (Unqual x)) = [x] +unqualNames' (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)) = 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. - 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' (L _ (HsVar _ x)) = Set.fromList $ unqualNames' x -- Variable. + freeVars' (L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes". + freeVars' (L _ (HsLam _ mg)) = free' (allVars' mg) -- Lambda abstraction. Currently always a single match. + freeVars' (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free' (allVars' ms) -- Lambda case + freeVars' (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars' of_ ^+ free' (allVars' ms) -- Case expr. + freeVars' (L _ (HsLet _ binds e)) = inFree' binds e -- Let (rec). + freeVars' (L _ (HsDo _ ctxt (L _ stmts))) = free' (allVars' stmts) -- Do block. + freeVars' (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars' flds -- Record construction. + freeVars' (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars' e : map freeVars' flds -- Record update. + freeVars' (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' (L _ HsConLikeOut{}) = mempty -- After typechecker. + freeVars' (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector. + freeVars' (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope 'fromLabel'. + freeVars' (L _ HsIPVar{}) = mempty -- Implicit parameter. + freeVars' (L _ HsOverLit{}) = mempty -- Overloaded literal. + freeVars' (L _ HsLit{}) = mempty -- Simple literal. + freeVars' (L _ HsRnBracketOut{}) = mempty -- Renamer produces these. + freeVars' (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these. + freeVars' (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@(L _ HsAppType{})) = freeVars' $ children e -- Visible type application e.g. 'f @ Int x y'. + -- freeVars' (e@(L _ HsApp{})) = freeVars' $ children e -- Application. + -- freeVars' (e@(L _ OpApp{})) = freeVars' $ children e -- Operator application. + -- freeVars' (e@(L _ NegApp{})) = freeVars' $ children e -- Negation operator. + -- freeVars' (e@(L _ HsPar{})) = freeVars' $ children e -- Parenthesized expr. + -- freeVars' (e@(L _ SectionL{})) = freeVars' $ children e -- Left section. + -- freeVars' (e@(L _ SectionR{})) = freeVars' $ children e -- Right section. + -- freeVars' (e@(L _ ExplicitTuple{})) = freeVars' $ children e -- Explicit tuple and sections thereof. + -- freeVars' (e@(L _ ExplicitSum{})) = freeVars' $ children e -- Used for unboxed sum types. + -- freeVars' (e@(L _ HsIf{})) = freeVars' $ children e -- If. + -- freeVars' (e@(L _ ExplicitList{})) = freeVars' $ children e -- Syntactic list e.g. '[a, b, c]'. + -- freeVars' (e@(L _ ExprWithTySig{})) = freeVars' $ children e -- Expr with type signature. + -- freeVars' (e@(L _ ArithSeq {})) = freeVars' $ children e -- Arithmetic sequence. + -- freeVars' (e@(L _ HsSCC{})) = freeVars' $ children e -- Set cost center pragma (expr whose const is to be measured). + -- freeVars' (e@(L _ HsCoreAnn{})) = freeVars' $ children e -- Pragma. + -- freeVars' (e@(L _ HsBracket{})) = freeVars' $ children e -- Haskell bracket. + -- freeVars' (e@(L _ HsSpliceE{})) = freeVars' $ children e -- Template haskell splice expr. + -- freeVars' (e@(L _ HsProc{})) = freeVars' $ children e -- Proc notation for arrows. + -- freeVars' (e@(L _ HsStatic{})) = freeVars' $ children e -- Static pointers extension. + -- freeVars' (e@(L _ HsArrApp{})) = freeVars' $ children e -- Arrow tail or arrow application. + -- freeVars' (e@(L _ HsArrForm{})) = freeVars' $ children e -- Come back to it. Arrow tail or arrow application. + -- freeVars' (e@(L _ HsTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support. + -- freeVars' (e@(L _ HsBinTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support. + -- freeVars' (e@(L _ HsTickPragma{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support. + -- freeVars' (e@(L _ EAsPat{})) = freeVars' $ children e -- Expr as pat. + -- freeVars' (e@(L _ EViewPat{})) = freeVars' $ children e -- View pattern. + -- freeVars' (e@(L _ ELazyPat{})) = freeVars' $ children e -- Lazy pattern. freeVars' e = freeVars' $ children e +instance FreeVars' (LHsTupArg GhcPs) where + freeVars' (L _ (Present _ args)) = freeVars' args + freeVars' _ = mempty + instance FreeVars' (LHsRecField GhcPs (LHsExpr GhcPs)) where - freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x + freeVars' (L _ (HsRecField _ x _)) = freeVars' x instance FreeVars' (LHsRecUpdField GhcPs) where - freeVars' (dL -> L _ (HsRecField _ x _)) = freeVars' x + freeVars' (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. +instance AllVars' (Located (Pat GhcPs)) where + allVars' (L _ (VarPat _ (L _ x))) = Vars' (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern. + allVars' (L _ (AsPat _ n x)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars' x -- As pattern. + allVars' (L _ (ConPatIn _ (RecCon (HsRecFields flds _)))) = allVars' flds + allVars' (L _ (NPlusKPat _ n _ _ _ _)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern. + allVars' (L _ (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' (L _ WildPat{}) = mempty -- Wildcard pattern. + allVars' (L _ ConPatOut{}) = mempty -- Renamer/typechecker. + allVars' (L _ LitPat{}) = mempty -- Literal pattern. + allVars' (L _ NPat{}) = mempty -- Natural pattern. -- allVars' p@SplicePat{} = allVars' $ children p -- Splice pattern (includes quasi-quotes). -- allVars' p@SigPat{} = allVars' $ children p -- Pattern with a type signature. @@ -180,76 +183,76 @@ allVars' p = allVars' $ children p -instance AllVars' (LHsRecField GhcPs (LPat GhcPs)) where - allVars' (dL -> L _ (HsRecField _ x _)) = allVars' x +instance AllVars' (LHsRecField GhcPs (Located (Pat GhcPs))) where + allVars' (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' (L _ (LastStmt _ expr _ _)) = freeVars_' expr -- The last stmt of a 'ListComp', 'MonadComp', 'DoExpr','MDoExpr'. + allVars' (L _ (BindStmt _ pat expr _ _)) = allVars' pat <> freeVars_' expr -- A generator e.g. 'x <- [1, 2, 3]'. + allVars' (L _ (BodyStmt _ expr _ _)) = freeVars_' expr -- A boolean guard e.g. 'even x'. + allVars' (L _ (LetStmt _ binds)) = allVars' binds -- A local declaration e.g. 'let y = x + 1' + allVars' (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars' stmts <> freeVars_' using <> maybe mempty freeVars_' by <> freeVars_' (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order. + allVars' (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' (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer. + allVars' (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' (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars' (bagToList binds) -- Value bindings. + allVars' (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' (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' (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' (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars' ms -- Function bindings and simple variable bindings e.g. 'f x = e', 'f !x = 3', 'f = e', '!x = e', 'x `f` y = e' + allVars' (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars' n <> allVars' grhss -- Ctor patterns and some other interesting cases e.g. 'Just x = e', '(x) = e', 'x :: Ty = e'. - allVars' (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' (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it. + allVars' (L _ VarBind{}) = mempty -- Typechecker. + allVars' (L _ AbsBinds{}) = mempty -- Not sure but I think renamer. 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)) + allVars' (MG _ _alts@(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)) = inVars' (allVars' pats) (allVars' grhss) -- Everything else. + allVars' (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars' (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars' pats <> allVars' grhss -- A pattern matching on an argument of a function binding. + allVars' (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars' ctxt <> allVars' pats <> allVars' grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc. + allVars' (L _ (Match _ _ pats grhss)) = inVars' (allVars' pats) (allVars' grhss) -- Everything else. allVars' _ = mempty -- New ctor. instance AllVars' (HsStmtContext RdrName) where - allVars' (PatGuard FunRhs{mc_fun=n}) = allVars' (VarPat noExt n :: Pat GhcPs) + allVars' (PatGuard FunRhs{mc_fun=n}) = allVars' (noLoc $ VarPat noExtField n :: LPat 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' (GRHSs _ grhss binds) = inVars' binds (mconcatMap allVars' grhss) allVars' _ = mempty -- New ctor. instance AllVars' (LGRHS GhcPs (LHsExpr GhcPs)) where - allVars' (dL -> L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards + allVars' (L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards allVars' _ = mempty -- New ctor. instance AllVars' (LHsDecl GhcPs) where - allVars' (dL -> L l (ValD _ bind)) = allVars' (cL l bind :: LHsBind GhcPs) + allVars' (L l (ValD _ bind)) = allVars' (L l bind :: LHsBind GhcPs) allVars' _ = mempty -- We only consider value bindings. @@ -263,6 +266,3 @@ 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 --- a/src/GHC/Util/HsDecl.hs +++ b/src/GHC/Util/HsDecl.hs @@ -1,20 +1,12 @@ {-# LANGUAGE NamedFieldPuns #-} -module GHC.Util.HsDecl (declName,bindName,isForD',isNewType',isDerivD',isClsDefSig') +module GHC.Util.HsDecl (declName,bindName) where -import HsSyn +import GHC.Hs import OccName import SrcLoc -isNewType' :: NewOrData -> Bool -isNewType' NewType = True -isNewType' DataType = False - -isForD', isDerivD' :: LHsDecl GhcPs -> Bool -isForD' (LL _ ForD{}) = True; isForD' _ = False -isDerivD' (LL _ DerivD{}) = True; isDerivD' _ = 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), @@ -22,7 +14,7 @@ -- want to tell users to rename binders that they aren't creating -- right now and therefore usually cannot change. declName :: LHsDecl GhcPs -> Maybe String -declName (LL _ x) = occNameString . occName <$> case x of +declName (L _ 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 @@ -36,13 +28,9 @@ ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name _ -> Nothing -declName _ = Nothing {- COMPLETE LL-} bindName :: LHsBind GhcPs -> Maybe String -bindName (LL _ FunBind{fun_id}) = Just $ occNameString $ occName $ unLoc fun_id -bindName (LL _ VarBind{var_id}) = Just $ occNameString $ occName var_id +bindName (L _ FunBind{fun_id}) = Just $ occNameString $ occName $ unLoc fun_id +bindName (L _ VarBind{var_id}) = Just $ occNameString $ occName var_id bindName _ = Nothing - -isClsDefSig' :: Sig GhcPs -> Bool -isClsDefSig' (ClassOpSig _ True _ _) = True; isClsDefSig' _ = False diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs --- a/src/GHC/Util/HsExpr.hs +++ b/src/GHC/Util/HsExpr.hs @@ -2,21 +2,18 @@ {-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TupleSections #-} --- Keep until 'descendApps', 'transformApps' and 'allowLeftSection' --- are used. -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - module GHC.Util.HsExpr ( - dotApp', dotApps' - , simplifyExp', niceLambda', niceDotApp' + dotApps', lambda + , simplifyExp', niceLambda', niceLambdaR' , Brackets'(..) , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp' , paren' , replaceBranches' - , needBracketOld', transformBracketOld', descendBracketOld', reduce', reduce1', fromParen1' + , needBracketOld', transformBracketOld', fromParen1' + , allowLeftSection, allowRightSection ) where -import HsSyn +import GHC.Hs import BasicTypes import SrcLoc import FastString @@ -27,7 +24,7 @@ import GHC.Util.Brackets import GHC.Util.View import GHC.Util.FreeVars -import GHC.Util.Pat +import GHC.Util.Outputable (unsafePrettyPrint) import Control.Applicative import Control.Monad.Trans.State @@ -37,21 +34,27 @@ import Data.List.Extra import Data.Tuple.Extra -import Refact.Types hiding (Match) +import Refact (toSS') +import Refact.Types hiding (SrcSpan, Match) import qualified Refact.Types as R (SrcSpan) +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -- | '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 +dotApp' x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (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) +-- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@ +lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs +lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated) + -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren' :: LHsExpr GhcPs -> LHsExpr GhcPs paren' x @@ -60,34 +63,27 @@ 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] + where f p = concat [(Just (i,p), c) : f c | (i,c) <- zipFrom 0 $ children p] apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs -apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y) +apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y) fromApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs] -fromApps' (LL _ (HsApp _ x y)) = fromApps' x ++ [y] +fromApps' (L _ (HsApp _ x y)) = fromApps' x ++ [y] fromApps' x = [x] childrenApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs] -childrenApps' (LL _ (HsApp _ x y)) = childrenApps' x ++ [y] +childrenApps' (L _ (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 (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp noExtField 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 @@ -95,7 +91,7 @@ descendIndex' f x = flip evalState 0 $ flip descendM x $ \y -> do i <- get modify (+1) - return $ f i y + pure $ f i y -- There are differences in pretty-printing between GHC and HSE. This -- version never removes brackets. @@ -104,7 +100,7 @@ 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 i y@(L _ e) | needBracket' i x y = addParen' y f _ y = y -- Add brackets as suggested 'needBracket' at 1-level of depth. @@ -114,16 +110,16 @@ -- 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) + where mkApp x y = rebracket1' (noLoc $ HsApp noExtField x y) 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)) = +simplifyExp' (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y))) +simplifyExp' e@(L _ (HsLet _ (L _ (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 _))))]) _) _ _)] + [L _ (FunBind _ _(MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (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 -> @@ -135,7 +131,7 @@ -- Rewrite '($) . b' as 'b'. niceDotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -niceDotApp' (LL _ (HsVar _ (L _ r))) b | occNameString (rdrNameOcc r) == "$" = b +niceDotApp' (L _ (HsVar _ (L _ r))) b | occNameString (rdrNameOcc r) == "$" = b niceDotApp' a b = dotApp' a b @@ -143,7 +139,9 @@ niceLambda' :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs niceLambda' ss e = fst (niceLambdaR' ss e)-- We don't support refactorings yet. +allowRightSection :: String -> Bool allowRightSection x = x `notElem` ["-","#"] +allowLeftSection :: String -> Bool allowLeftSection x = x /= "#" -- Implementation. Try to produce special forms (e.g. sections, @@ -152,59 +150,110 @@ -> 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 +-- Rewrite @\ -> e@ as @e@ +-- These are encountered as recursive calls. +niceLambdaR' xs (SimpleLambda [] x) = niceLambdaR' xs x + +-- Rewrite @\xs -> (e)@ as @\xs -> e@. +niceLambdaR' xs (L _ (HsPar _ x)) = niceLambdaR' xs x + +-- @\vs v -> ($) e v@ ==> @\vs -> e@ +-- @\vs v -> e $ v@ ==> @\vs -> e@ +niceLambdaR' (unsnoc -> Just (vs, v)) (view' -> App2' f e (view' -> Var_' v')) + | isDol f + , v == v' + , vars' e `disjoint` [v] + = niceLambdaR' vs e + +-- @\v -> thing + v@ ==> @\v -> (thing +)@ (heuristic: @v@ must be a single +-- lexeme, or it all gets too complex) +niceLambdaR' [v] (L _ (OpApp _ e f (view' -> Var_' v'))) + | isLexeme e + , v == v' + , vars' e `disjoint` [v] + , L _ (HsVar _ (L _ fname)) <- f + , isSymOcc $ rdrNameOcc fname + = (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)]) + +-- @\vs v -> f x v@ ==> @\vs -> f x@ +niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (HsApp _ (L _ (HsApp _ f e)) (view' -> Var_' v'))) + | v == v' + , vars' e `disjoint` [v] + = niceLambdaR' vs $ apps' [f, e] + +-- @\vs v -> (v `f`)@ ==> @\vs -> f@ +niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view' -> Var_' v') f)) + | v == v' = niceLambdaR' vs f + +-- Strip one variable pattern from the end of a lambdas match, and place it in our list of factoring variables. +niceLambdaR' xs (SimpleLambda ((view' -> PVar_' v):vs) x) + | v `notElem` xs = niceLambdaR' (xs++[v]) $ lambda vs x + +-- Rewrite @\x -> x + a@ as @(+ a)@ (heuristic: @a@ must be a single -- lexeme, or it all gets too complex). -niceLambdaR' [x] (view' -> App2' op@(LL _ (HsVar _ (L _ tag))) l r) +niceLambdaR' [x] (view' -> App2' op@(L _ (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'. + let e = rebracket1' $ addParen' (noLoc $ SectionR noExtField op r) + in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)]) +-- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@. niceLambdaR' [x] y - | Just (z, subts) <- factor y, x `notElem` vars' z = (z, const []) + | Just (z, subts) <- factor y, x `notElem` vars' z = (z, \s -> [mkRefact subts s]) where -- Factor the expression with respect to x. factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) - factor y@(LL _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini]) - factor y@(LL _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst + factor y@(L _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini]) + factor y@(L _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst = let r = niceDotApp' ini z in if astEq r z then Just (r, ss) else Just (r, ini : ss) - factor (LL _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op + factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op = let r = niceDotApp' y z in if astEq r z then Just (r, ss) else Just (r, y : ss) - factor (LL _ (HsPar _ y@(LL _ HsApp{}))) = factor y + factor (L _ (HsPar _ y@(L _ 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'. + mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan + mkRefact subts s = + let tempSubts = zipWith (\a b -> ([a], toSS' b)) ['a' .. 'z'] subts + template = dotApps' (map (strToVar . fst) tempSubts) + in Replace Expr s tempSubts (unsafePrettyPrint template) +-- Rewrite @\x y -> x + y@ as @(+)@. +niceLambdaR' [x,y] (L _ (OpApp _ (view' -> Var_' x1) op@(L _ HsVar {}) (view' -> Var_' y1))) + | x == x1, y == y1, vars' op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)]) +-- Rewrite @\x y -> f y x@ as @flip f@. niceLambdaR' [x, y] (view' -> App2' op (view' -> Var_' y1) (view' -> Var_' x1)) - | x == x1, y == y1, vars' op `disjoint` [x, y] = (noLoc $ HsApp noExt (strToVar "flip") op, const []) + | x == x1, y == y1, vars' op `disjoint` [x, y] = + ( gen op + , \s -> [Replace Expr s [("x", toSS' op)] (unsafePrettyPrint $ gen (strToVar "x"))] + ) + where + gen = noLoc . HsApp noExtField (strToVar "flip") + +-- We're done factoring, but have no variables left, so we shouldn't make a lambda. +-- @\ -> e@ ==> @e@ +niceLambdaR' [] e = (e, 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 []) + let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) + grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField} + match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs) + matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]} + in (noLoc $ HsLam noExtField matchGroup, const []) -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches' :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs) -replaceBranches' (LL l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExt Nothing a b c)) +replaceBranches' (L l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExtField Nothing a b c)) -replaceBranches' (LL s (HsCase _ a (MG _ (L l bs) FromSource))) = - (concatMap f bs, \xs -> cL s (HsCase noExt a (MG noExt (cL l (g bs xs)) Generated))) +replaceBranches' (L s (HsCase _ a (MG _ (L l bs) FromSource))) = + (concatMap f bs, \xs -> cL s (HsCase noExtField a (MG noExtField (cL l (g bs xs)) Generated))) where f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs] - f (LL _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (LL _ (GRHS _ _ x)) <- xs] - f _ = undefined -- {-# COMPLETE LL #-} + f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs] + f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch" g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)] - g (LL s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs = - cL s1 (Match noExt CaseAlt a (GRHSs noExt [cL a (GRHS noExt gs x) | (LL a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs + g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs = + cL s1 (Match noExtField CaseAlt a (GRHSs noExtField [cL a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs where (as, bs) = splitAt (length ns) xs g [] [] = [] g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths" @@ -240,32 +289,13 @@ g1 = (fst .) . g g2 = (snd .) . g - f i (LL _ (HsPar _ y)) z | not $ needBracketOld' i x y = (y, z) - f i y z | needBracketOld' i x y = (addParen' y, addParen' z) - f _ y z = (y, z) + f i (L _ (HsPar _ y)) z | not $ needBracketOld' i x y = (y, z) + f i y z | needBracketOld' i x y = (addParen' y, addParen' z) + f _ y z = (y, z) f1 = ((fst .) .) . f f2 = ((snd .) .) . f -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 (astEq 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' (L _ (HsPar _ x)) = x fromParen1' x = x diff --git a/src/GHC/Util/HsType.hs b/src/GHC/Util/HsType.hs deleted file mode 100644 --- a/src/GHC/Util/HsType.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module GHC.Util.HsType ( - Brackets'(..) - , fromTyParen' - , isTyQuasiQuote' - , isUnboxedTuple' - ) where - -import HsSyn -import SrcLoc - -import GHC.Util.Brackets - -fromTyParen' :: LHsType GhcPs -> LHsType GhcPs -fromTyParen' (LL _ (HsParTy _ x)) = x -fromTyParen' x = x - -isTyQuasiQuote' :: LHsType GhcPs -> Bool -isTyQuasiQuote' (LL _ (HsSpliceTy _ HsQuasiQuote{})) = True; isTyQuasiQuote' _ = False - -isUnboxedTuple' :: HsTupleSort -> Bool -isUnboxedTuple' HsUnboxedTuple = True -isUnboxedTuple' _ = False diff --git a/src/GHC/Util/LanguageExtensions/Type.hs b/src/GHC/Util/LanguageExtensions/Type.hs deleted file mode 100644 --- a/src/GHC/Util/LanguageExtensions/Type.hs +++ /dev/null @@ -1,13 +0,0 @@ - -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 --- a/src/GHC/Util/Module.hs +++ b/src/GHC/Util/Module.hs @@ -1,15 +1,13 @@ module GHC.Util.Module (modName, fromModuleName') where -import HsSyn +import GHC.Hs 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 #-} +modName (L _ HsModule {hsmodName=Nothing}) = "Main" +modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n fromModuleName' :: Located ModuleName -> String -fromModuleName' (LL _ n) = moduleNameString n -fromModuleName' _ = "" -- {# COMPLETE LL #} +fromModuleName' (L _ n) = moduleNameString n diff --git a/src/GHC/Util/Pat.hs b/src/GHC/Util/Pat.hs deleted file mode 100644 --- a/src/GHC/Util/Pat.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} - -module GHC.Util.Pat ( - strToPat', patToStr' - , Brackets'(..) - , fromPChar', isPFieldWildcard', hasPFieldsDotDot', isPWildCard' - , isPFieldPun', isPatTypeSig', isPBangPat', isPViewPat' - ) 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 #-} - -isPWildCard' :: Pat GhcPs -> Bool -isPWildCard' (LL _ (WildPat _)) = True -isPWildCard' _ = False - -isPFieldPun' :: LHsRecField GhcPs (Pat GhcPs) -> Bool -isPFieldPun' (LL _ HsRecField {hsRecPun=True}) = True -isPFieldPun' _ = False - -isPatTypeSig', isPBangPat', isPViewPat' :: Pat GhcPs -> Bool -isPatTypeSig' (LL _ SigPat{}) = True; isPatTypeSig' _ = False -isPBangPat' (LL _ BangPat{}) = True; isPBangPat' _ = False -isPViewPat' (LL _ ViewPat{}) = True; isPViewPat' _ = False diff --git a/src/GHC/Util/Scope.hs b/src/GHC/Util/Scope.hs --- a/src/GHC/Util/Scope.hs +++ b/src/GHC/Util/Scope.hs @@ -2,11 +2,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Util.Scope ( - Scope' - ,scopeCreate',scopeImports',scopeMatch',scopeMove' + Scope + ,scopeCreate,scopeMatch,scopeMove ) where -import HsSyn +import GHC.Hs import SrcLoc import BasicTypes import Module @@ -16,24 +16,25 @@ import GHC.Util.Module import GHC.Util.RdrName -import Outputable +import GHC.Util.Outputable -import Data.List import Data.List.Extra import Data.Maybe -- A scope is a list of import declarations. -newtype Scope' = Scope' [LImportDecl GhcPs] - deriving (Outputable, Monoid, Semigroup) +newtype Scope = Scope [LImportDecl GhcPs] + deriving (Monoid, Semigroup) --- Create a 'Scope' from a module's import declarations. -scopeCreate' :: HsModule GhcPs -> Scope' -scopeCreate' xs = Scope' $ [prelude | not $ any isPrelude res] ++ res +instance Show Scope where + show (Scope x) = unsafePrettyPrint x + +-- Create a 'Scope from a module's import declarations. +scopeCreate :: HsModule GhcPs -> Scope +scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res where -- Package qualifier of an import declaration. pkg :: LImportDecl GhcPs -> Maybe StringLiteral - pkg (LL _ x) = ideclPkgQual x - pkg _ = Nothing -- {-# COMPLETE LL #-} + pkg (L _ x) = ideclPkgQual x -- The import declaraions contained by the module 'xs'. res :: [LImportDecl GhcPs] @@ -45,48 +46,43 @@ -- 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 + isPrelude (L _ x) = fromModuleName' (ideclName x) == "Prelude" -- Test if two names in two scopes may be referring to the same -- thing. This is the case if the names are equal and (1) denote a -- builtin type or data constructor or (2) the intersection of the -- candidate modules where the two names arise is non-empty. -scopeMatch' :: (Scope', Located RdrName) -> (Scope', Located RdrName) -> Bool -scopeMatch' (a, x) (b, y) +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) + rdrNameStr' (unqual' x) == rdrNameStr' (unqual' y) && not (possModules a x `disjoint` 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) = case imps of - [] -> head $ real ++ [x] - imp:_ | all ideclQualified imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name +scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName +scopeMove (a, x@(fromQual' -> Just name)) (Scope b) = case imps of + [] -> headDef x real + imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name | otherwise -> unqual' x where real :: [Located RdrName] - real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules' a x] + 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 + 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 +possModules :: Scope -> Located RdrName -> [String] +possModules (Scope is) x = f x where res :: [String] - res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport' i x] + res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport i x] f :: Located RdrName -> [String] f n | isSpecial' n = [""] @@ -95,12 +91,12 @@ -- 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) +possImport :: LImportDecl GhcPs -> Located RdrName -> Bool +possImport i n | isSpecial' n = False +possImport (L _ i) (L _ (Qual mod x)) = + moduleNameString mod `elem` map fromModuleName' ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x) where ms = ideclName i : maybeToList (ideclAs i) -possImport' (LL _ i) (L _ (Unqual x)) = not (ideclQualified i) && maybe True f (ideclHiding i) +possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i) where f :: (Bool, Located [LIE GhcPs]) -> Bool f (hide, L _ xs) = @@ -122,4 +118,4 @@ unwrapName :: LIEWrappedName RdrName -> String unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x)) -possImport' _ _ = False -- {-# COMPLETE LL #-} +possImport _ _ = False diff --git a/src/GHC/Util/Unify.hs b/src/GHC/Util/Unify.hs --- a/src/GHC/Util/Unify.hs +++ b/src/GHC/Util/Unify.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module GHC.Util.Unify( Subst', fromSubst', - validSubst', substitute', - unifyExp' + validSubst', removeParens, substitute', + unifyExp ) where +import Control.Applicative import Control.Monad import Data.Generics.Uniplate.Operations import Data.Char -import Data.List.Extra import Data.Data -import Data.Tuple.Extra +import Data.List.Extra import Util -import HsSyn +import GHC.Hs import SrcLoc as GHC import Outputable hiding ((<>)) import RdrName import OccName +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util.Outputable import GHC.Util.HsExpr -import GHC.Util.Pat import GHC.Util.RdrName import GHC.Util.View @@ -39,15 +39,12 @@ -- 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) + deriving (Semigroup, Monoid, Functor) -- 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] @@ -57,6 +54,12 @@ where f (x, y : ys) | all (eq y) ys = Just (x, y) f _ = Nothing +-- Remove unnecessary brackets from a Subst'. The first argument is a list of unification variables +-- for which brackets should be removed from their substitutions. +removeParens :: [String] -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs) +removeParens noParens (Subst' xs) = Subst' $ + map (\(x, y) -> if x `elem` noParens then (x, fromParen' y) else (x, y)) xs + -- Peform a substition. -- Returns (suggested replacement, refactor template), both with brackets added -- as needed. @@ -66,28 +69,28 @@ where exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) -- Variables. - exp (LL _ (HsVar _ x)) = lookup (rdrNameStr' x) bind + exp (L _ (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)) + exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs)) + | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (OpApp noExtField 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)) + exp (L loc (SectionL _ exp (L _ (HsVar _ x)))) + | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionL noExtField 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 (L loc (SectionR _ (L _ (HsVar _ x)) exp)) + | Just y <- lookup (rdrNameStr' x) bind = Just (cL loc (SectionR noExtField 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 (L _ (VarPat _ x)) + | Just y@(L _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat $ varToStr y pat x = x :: LPat GhcPs typ :: LHsType GhcPs -> LHsType GhcPs -- Type variables. - typ (LL _ (HsTyVar _ _ x)) - | Just (LL _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr' x) bind = y + typ (L _ (HsTyVar _ _ x)) + | Just (L _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr' x) bind = y typ x = x :: LHsType GhcPs @@ -109,6 +112,65 @@ unifyDef' :: Data a => NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs)) unifyDef' nm x y = fmap mconcat . sequence =<< gzip (unify' nm False) x y +unifyComposed' :: NameMatch' + -> LHsExpr GhcPs + -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -> Maybe (Subst' (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) +unifyComposed' nm x1 y11 dot y12 = + ((, Just y11) <$> unifyExp' nm False x1 y12) + <|> case y12 of + (L _ (OpApp _ y121 dot' y122)) | isDot dot' -> + unifyComposed' nm x1 (noLoc (OpApp noExtField y11 dot y121)) dot' y122 + _ -> Nothing + +-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise, +-- delegate to unifyExp'. These are the cases where we potentially need to call +-- unifyComposed' to handle left composition. +-- +-- y is allowed to partially match x (the lhs of the hint), if y is a function application where +-- the function is a composition of functions. In this case the second component of the result is +-- the unmatched part of y, which will be attached to the rhs of the hint after substitution. +-- +-- Example: +-- x = head (drop n x) +-- y = foo . bar . baz . head $ drop 2 xs +-- result = (Subst' [(n, 2), (x, xs)], Just (foo . bar . baz)) +unifyExp :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) +-- Match wildcard operators. +unifyExp nm root (L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr' -> v))) rhs1)) + (L _ (OpApp _ lhs2 (L _ (HsVar _ (rdrNameStr' -> op2))) rhs2)) + | isUnifyVar v = + (, Nothing) . (Subst' [(v, strToVar op2)] <>) <$> + liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2) + +-- Options: match directly, and expand through '.' +unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) = + ((, Nothing) <$> liftA2 (<>) (unifyExp' nm False x1 y1) (unifyExp' nm False x2 y2)) <|> unifyComposed + where + -- Unify a function application where the function is a composition of functions. + unifyComposed + | (L _ (OpApp _ y11 dot y12)) <- fromParen' y1, isDot dot = + -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'. + -- The guard ensures that you don't get duplicate matches because the matching engine + -- auto-generates hints in dot-form. + (guard (not root) >> (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))) + -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg', + -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg', + -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'. + <|> do + rhs <- unifyExp' nm False x2 y2 + (lhs, extra) <- unifyComposed' nm x1 y11 dot y12 + pure (lhs <> rhs, extra) + | otherwise = Nothing + +-- Options: match directly, then expand through '$', then desugar infix. +unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) + | (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x = + guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2) + | isDol op2 = unifyExp nm root x $ noLoc (HsApp noExtField lhs2 rhs2) + | otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 lhs2)) rhs2) +unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y + -- 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 @@ -119,67 +181,52 @@ 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 +unifyExp' nm root (L _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst' [(v, y)] +unifyExp' nm root (L _ (HsVar _ x)) (L _ (HsVar _ y)) | nm x y = Just mempty --- 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))))) +unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr' -> v))) rhs1)) + y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) = + fst <$> unifyExp nm root x y +unifyExp' nm root (L _ (SectionL _ exp1 (L _ (HsVar _ (rdrNameStr' -> v))))) + (L _ (SectionL _ exp2 (L _ (HsVar _ (rdrNameStr' -> op2))))) | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 -unifyExp' nm root (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> v))) exp1)) - (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> op2))) exp2)) +unifyExp' nm root (L _ (SectionR _ (L _ (HsVar _ (rdrNameStr' -> v))) exp1)) + (L _ (SectionR _ (L _ (HsVar _ (rdrNameStr' -> op2))) exp2)) | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 --- 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)))) - ) +unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) = + fst <$> unifyExp nm root x y --- 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@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) = + fst <$> unifyExp nm root x y 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 (L _ HsVar{}) = False + isOther (L _ HsApp{}) = False + isOther (L _ OpApp{}) = False isOther _ = True unifyExp' _ _ _ _ = Nothing unifyPat' :: NameMatch' -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs)) -unifyPat' nm (LL _ (VarPat _ x)) (LL _ (VarPat _ y)) = +unifyPat' nm (L _ (VarPat _ x)) (L _ (VarPat _ y)) = Just $ Subst' [(rdrNameStr' x, strToVar(rdrNameStr' y))] -unifyPat' nm (LL _ (VarPat _ x)) (LL _ (WildPat _)) = +unifyPat' nm (L _ (VarPat _ x)) (L _ (WildPat _)) = let s = rdrNameStr' x in Just $ Subst' [(s, strToVar("_" ++ s))] -unifyPat' nm (LL _ (ConPatIn x _)) (LL _ (ConPatIn y _)) | rdrNameStr' x /= rdrNameStr' y = +unifyPat' nm (L _ (ConPatIn x _)) (L _ (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 +unifyType' nm (L loc (HsTyVar _ _ x)) y = + let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs) + unused = noLoc (HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "__unused__"))) :: LHsExpr GhcPs + appType = cL loc (HsAppType noExtField unused wc) :: LHsExpr GhcPs in Just $ Subst' [(rdrNameStr' x, appType)] unifyType' nm x y = unifyDef' nm x y diff --git a/src/GHC/Util/View.hs b/src/GHC/Util/View.hs --- a/src/GHC/Util/View.hs +++ b/src/GHC/Util/View.hs @@ -1,23 +1,25 @@ -{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-} module GHC.Util.View ( - fromParen', fromPParen' + fromParen' , View'(..) , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2'),LamConst1'(LamConst1') + , pattern SimpleLambda ) where -import HsSyn +import GHC.Hs import SrcLoc import RdrName import OccName import BasicTypes +import GHC.Util.RdrName (rdrNameStr') fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs -fromParen' (LL _ (HsPar _ x)) = fromParen' x +fromParen' (L _ (HsPar _ x)) = fromParen' x fromParen' x = x -fromPParen' :: Pat GhcPs -> Pat GhcPs -fromPParen' (LL _ (ParPat _ x)) = fromPParen' x +fromPParen' :: LPat GhcPs -> LPat GhcPs +fromPParen' (L _ (ParPat _ x)) = fromPParen' x fromPParen' x = x class View' a b where @@ -25,31 +27,35 @@ data Var_' = NoVar_' | Var_' String deriving Eq data PVar_' = NoPVar_' | PVar_' String -data PApp_' = NoPApp_' | PApp_' String [Pat GhcPs] +data PApp_' = NoPApp_' | PApp_' String [LPat GhcPs] data App2' = NoApp2' | App2' (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs) data LamConst1' = NoLamConst1' | LamConst1' (LHsExpr GhcPs) instance View' (LHsExpr GhcPs) LamConst1' where - view' (fromParen' -> (LL _ (HsLam _ (MG _ (L _ [LL _ (Match _ LambdaExpr [LL _ WildPat {}] - (GRHSs _ [LL _ (GRHS _ [] x)] (LL _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x + view' (fromParen' -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}] + (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x view' _ = NoLamConst1' instance View' (LHsExpr GhcPs) Var_' where - view' (fromParen' -> (LL _ (HsVar _ (LL _ (Unqual x))))) = Var_' $ occNameString x + view' (fromParen' -> (L _ (HsVar _ (rdrNameStr' -> x)))) = Var_' 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' (fromParen' -> L _ (OpApp _ lhs op rhs)) = App2' op lhs rhs + view' (fromParen' -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2' f x y view' _ = NoApp2' -instance View' (Pat GhcPs) PVar_' where - view' (fromPParen' -> LL _ (VarPat _ (L _ x))) = PVar_' $ occNameString (rdrNameOcc x) +instance View' (Located (Pat GhcPs)) PVar_' where + view' (fromPParen' -> L _ (VarPat _ (L _ x))) = PVar_' $ occNameString (rdrNameOcc x) view' _ = NoPVar_' -instance View' (Pat GhcPs) PApp_' where - view' (fromPParen' -> LL _ (ConPatIn (L _ x) (PrefixCon args))) = +instance View' (Located (Pat GhcPs)) PApp_' where + view' (fromPParen' -> L _ (ConPatIn (L _ x) (PrefixCon args))) = PApp_' (occNameString . rdrNameOcc $ x) args - view' (fromPParen' -> LL _ (ConPatIn (L _ x) (InfixCon lhs rhs))) = + view' (fromPParen' -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) = PApp_' (occNameString . rdrNameOcc $ x) [lhs, rhs] view' _ = NoPApp_' + +-- A lambda with no guards and no where clauses +pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs +pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _)) diff --git a/src/Grep.hs b/src/Grep.hs --- a/src/Grep.hs +++ b/src/Grep.hs @@ -10,29 +10,32 @@ import Util import Idea -import qualified HsSyn as GHC +import qualified GHC.Hs as GHC import qualified BasicTypes as GHC +import qualified Outputable +import qualified ErrUtils +import Lexer import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import SrcLoc as GHC hiding (mkSrcSpan) +import GHC.Util.DynFlags +import Bag runGrep :: String -> ParseFlags -> [FilePath] -> IO () runGrep patt flags files = do - exp <- case parseExp patt of - ParseOk x -> return x - ParseFailed sl msg -> - exitMessage $ (if "Parse error" `isPrefixOf` msg then msg else "Parse error in pattern: " ++ msg) ++ "\n" ++ - patt ++ "\n" ++ - replicate (srcColumn sl - 1) ' ' ++ "^" - let scope = scopeCreate $ Module an Nothing [] [] [] - let 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. - (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing] + exp <- case parseExpGhcWithMode flags patt of + POk _ a -> pure a + PFailed ps -> exitMessage $ + let (_, errs) = getMessages ps baseDynFlags + errMsg = head (bagToList errs) + msg = Outputable.showSDoc baseDynFlags $ ErrUtils.pprLocErrMsg errMsg + in "Failed to parse " ++ msg ++ ", when parsing:\n " ++ patt + let ghcUnit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExtField [] GHC.Boxed + let rule = hintRules [HintRule Suggestion "grep" [] mempty (extendInstances exp) (extendInstances ghcUnit) Nothing] forM_ files $ \file -> do res <- parseModuleEx flags file Nothing case res of Left (ParseError sl msg ctxt) -> - print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing [] + print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) sl ctxt Nothing [] Right m -> forM_ (applyHints [] rule [m]) $ \i -> print i{ideaHint="", ideaTo=Nothing} diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -1,13 +1,14 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module HLint(hlint, readAllSettings) where import Control.Applicative import Control.Monad.Extra -import Control.Exception +import Control.Exception.Extra import Control.Concurrent.Extra import System.Console.CmdArgs.Verbosity +import GHC.Util.DynFlags import Data.List.Extra import GHC.Conc import System.Exit @@ -16,11 +17,6 @@ import Data.Tuple.Extra import Prelude -import Data.Version.Extra -import System.Process.Extra -import Data.Maybe -import System.Directory - import CmdLine import Config.Read import Config.Type @@ -31,6 +27,7 @@ import Test.All import Hint.All import Grep +import Refact import Timing import Test.Proof import Parallel @@ -53,6 +50,7 @@ -- on your server with untrusted input. hlint :: [String] -> IO [Idea] hlint args = do + initGlobalDynFlags cmd <- getCmd args case cmd of CmdMain{} -> do @@ -61,27 +59,9 @@ when (cmdTiming cmd) $ do printTimings putStrLn $ "Took " ++ showDuration time - return $ if cmdNoExitCode cmd then [] else xs - CmdGrep{} -> hlintGrep cmd >> return [] - CmdHSE{} -> hlintHSE cmd >> return [] - CmdTest{} -> hlintTest cmd >> return [] - -hlintHSE :: Cmd -> IO () -hlintHSE c@CmdHSE{..} = do - v <- getVerbosity - forM_ cmdFiles $ \x -> do - putStrLn $ "Parse result of " ++ x ++ ":" - let (lang,exts) = cmdExtensions c - -- We deliberately don't use HSE.All here to avoid any bugs in HLint - -- polluting our bug reports (which is the main use of HSE) - res <- parseFileWithMode defaultParseMode{baseLanguage=lang, extensions=exts} x - case res of - x@ParseFailed{} -> print x - ParseOk m -> case v of - Loud -> print m - Quiet -> print $ prettyPrint m - _ -> print $ void m - putStrLn "" + pure $ if cmdNoExitCode cmd then [] else xs + CmdGrep{} -> hlintGrep cmd >> pure [] + CmdTest{} -> hlintTest cmd >> pure [] hlintTest :: Cmd -> IO () hlintTest cmd@CmdTest{..} = @@ -104,7 +84,7 @@ else do files <- concatMapM (resolveFile cmd Nothing) cmdFiles if null files then - error "No files found" + errorIO "No files found" else runGrep cmdPattern (cmdParseFlags cmd) files @@ -116,7 +96,7 @@ hlintMain :: [String] -> Cmd -> IO [Idea] hlintMain args cmd@CmdMain{..} | cmdDefault = do - ideas <- if null cmdFiles then return [] else withVerbosity Quiet $ + ideas <- if null cmdFiles then pure [] else withVerbosity Quiet $ runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing let bad = nubOrd $ map ideaHint ideas if null bad then putStr defaultYaml else do @@ -124,10 +104,10 @@ let group2 = "# Warnings currently triggered by your code" : ["- ignore: {name: " ++ show x ++ "}" | x <- bad] putStr $ unlines $ intercalate ["",""] $ group1:group2:groups - return [] + pure [] | null cmdFiles && not (null cmdFindHints) = do hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints - mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> return [] + mapM_ (putStrLn . fst <=< computeSettings (cmdParseFlags cmd)) hints >> pure [] | null cmdFiles = exitWithHelp | cmdRefactor = @@ -154,13 +134,12 @@ settings1 <- readFilesConfig $ files - ++ [("CommandLine.hs",Just x) | x <- cmdWithHints] ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups] let args2 = [x | SettingArgument x <- settings1] - cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last + cmd@CmdMain{..} <- if null args2 then pure cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints - settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] - return (cmd, settings1 ++ settings2 ++ settings3) + let settings3 = [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] + pure (cmd, settings1 ++ settings2 ++ settings3) where enableGroup groupName = unlines @@ -171,11 +150,11 @@ runHints :: [String] -> [Setting] -> Cmd -> IO [Idea] runHints args settings cmd@CmdMain{..} = do - j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads + j <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads withNumCapabilities j $ do let outStrLn = whenNormal . putStrLn ideas <- getIdeas cmd settings - ideas <- return $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas + ideas <- pure $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas if cmdJson then putStrLn $ showIdeasJson ideas else if cmdCC then @@ -187,19 +166,19 @@ handleRefactoring ideas cmdFiles cmd else do usecolour <- cmdUseColour cmd - showItem <- if usecolour then showANSI else return show + showItem <- if usecolour then showANSI else pure show mapM_ (outStrLn . showItem) ideas handleReporting ideas cmd - return ideas + pure ideas getIdeas :: Cmd -> [Setting] -> IO [Idea] getIdeas cmd@CmdMain{..} settings = do - settings <- return $ settings ++ map (Builtin . fst) builtinHints + settings <- pure $ settings ++ map (Builtin . fst) builtinHints let flags = cmdParseFlags cmd ideas <- if cmdCross then applyHintFiles flags settings cmdFiles else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles] - return $ if not (null cmdOnly) + pure $ if not (null cmdOnly) then [i | i <- ideas, ideaHint i `elem` cmdOnly] else ideas @@ -215,7 +194,7 @@ withTempFile $ \f -> do writeFile f hints exitWith =<< runRefactoring path file f cmdRefactorOptions - _ -> error "Refactor flag can only be used with an individual file" + _ -> errorIO "Refactor flag can only be used with an individual file" handleReporting :: [Idea] -> Cmd -> IO () @@ -228,28 +207,7 @@ let n = length showideas outStrLn $ if n == 0 then "No hints" else show n ++ " hint" ++ ['s' | n/=1] -runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode -runRefactoring rpath fin hints opts = do - let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints] - (_, _, _, phand) <- createProcess $ proc rpath args - try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) - hSetBuffering stdout LineBuffering - -- Propagate the exit code from the spawn process - waitForProcess phand - -checkRefactor :: Maybe FilePath -> IO FilePath -checkRefactor rpath = do - let excPath = fromMaybe "refactor" rpath - mexc <- findExecutable excPath - case mexc of - Just exc -> do - ver <- readVersion . tail <$> readProcess exc ["--version"] "" - if versionBranch ver >= [0,1,0,0] - then return exc - else error "Your version of refactor is too old, please upgrade to the latest version" - Nothing -> error $ unlines [ "Could not find refactor", "Tried with: " ++ excPath ] - evaluateList :: [a] -> IO [a] evaluateList xs = do evaluate $ length xs - return xs + pure xs diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -1,24 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} module HSE.All( - module X, CppFlags(..), ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetLanguage, ParseError(..), ModuleEx(..), parseModuleEx, ghcComments, - freeVars, vars, varss, pvars, - ghcSpanToHSE, ghcSrcLocToHSE, - parseExpGhcWithMode, parseImportDeclGhcWithMode + parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode, ) where -import Language.Haskell.Exts.Util hiding (freeVars, Vars(..)) -import qualified Language.Haskell.Exts.Util as X -import HSE.Util as X -import HSE.Type as X -import HSE.Match as X -import HSE.Scope as X import Util import Data.Char import Data.List.Extra @@ -26,57 +16,29 @@ import Timing import Language.Preprocessor.Cpphs import Data.Either -import Data.Set (Set) +import DynFlags(Language(..)) import qualified Data.Map as Map -import qualified Data.Set as Set import System.IO.Extra import Data.Functor +import Fixity +import Extension +import FastString import Prelude -import qualified HsSyn -import qualified FastString +import GHC.Hs import qualified SrcLoc as GHC -import qualified ErrUtils +import ErrUtils import qualified Outputable import qualified Lexer as GHC -import qualified GHC.LanguageExtensions.Type as GHC +import GHC.LanguageExtensions.Type import qualified ApiAnnotation as GHC import qualified BasicTypes as GHC import qualified DynFlags as GHC +import Bag -import GHC.Util +import GHC.Util (parsePragmasIntoDynFlags, parseFileGhcLib, parseExpGhcLib, parseDeclGhcLib, parseImportGhcLib, baseDynFlags) import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx --- | Convert a GHC source loc into an HSE equivalent. -ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc -ghcSrcLocToHSE (GHC.RealSrcLoc l) = - SrcLoc { - srcFilename = FastString.unpackFS (GHC.srcLocFile l) - , srcLine = GHC.srcLocLine l - , srcColumn = GHC.srcLocCol l - } -ghcSrcLocToHSE (GHC.UnhelpfulLoc _) = noLoc - --- | Convert a GHC source span into an HSE equivalent. -ghcSpanToHSE :: GHC.SrcSpan -> SrcSpan -ghcSpanToHSE (GHC.RealSrcSpan s) = - SrcSpan { - srcSpanFilename = FastString.unpackFS (GHC.srcSpanFile s) - , srcSpanStartLine = GHC.srcSpanStartLine s - , srcSpanStartColumn = GHC.srcSpanStartCol s - , srcSpanEndLine = GHC.srcSpanEndLine s - , srcSpanEndColumn = GHC.srcSpanEndCol s - } -ghcSpanToHSE (GHC.UnhelpfulSpan _) = mkSrcSpan noLoc noLoc - -vars :: FreeVars a => a -> [String] -freeVars :: FreeVars a => a -> Set String -varss, pvars :: AllVars a => a -> [String] -vars = Set.toList . Set.map prettyPrint . X.freeVars -varss = Set.toList . Set.map prettyPrint . X.free . X.allVars -pvars = Set.toList . Set.map prettyPrint . X.bound . X.allVars -freeVars = Set.map prettyPrint . X.freeVars - -- | What C pre processor should be used. data CppFlags = NoCpp -- ^ No pre processing is done. @@ -86,93 +48,26 @@ -- | Created with 'defaultParseFlags', used by 'parseModuleEx'. data ParseFlags = ParseFlags {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp'). - ,hseFlags :: ParseMode -- ^ How the file is parsed (defaults to all fixities in the @base@ package and most non-conflicting extensions). + ,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'. + ,extensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions. + ,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@. } -lensFixities :: [Fixity] -lensFixities = concat - -- List as provided at https://github.com/ndmitchell/hlint/issues/416 - [infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","","??"] - ,infixl_ 8 ["^.","^@."] - ,infixr_ 9 ["<.>","<.",".>"] - ,infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"] - ,infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="] - ,infixr_ 2 ["<~"] - ,infixr_ 2 ["`zoom`","`magnify`"] - ,infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"] - ,infixl_ 8 ["^#"] - ,infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"] - ,infix_ 4 ["<#=","#=","#%=","<#%=","#%%="] - ,infixl_ 9 [":>"] - ,infixr_ 4 ["~","<~","<.>~","<<.>~"] - ,infix_ 4 ["=","<=","<.>=","<<.>="] - ,infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"] - ,infix_ 4 [".|.=",".&.=","<.|.=","<.&.="] - ] - -otherFixities :: [Fixity] -otherFixities = concat - -- hspec - [infix_ 1 ["`shouldBe`","`shouldSatisfy`","`shouldStartWith`","`shouldEndWith`","`shouldContain`","`shouldMatchList`" - ,"`shouldReturn`","`shouldNotBe`","`shouldNotSatisfy`","`shouldNotContain`","`shouldNotReturn`","`shouldThrow`"] - -- quickcheck - ,infixr_ 0 ["==>"] - ,infix_ 4 ["==="] - -- esqueleto - ,infix_ 4 ["==."] - -- lattices - ,infixr_ 5 ["\\/"] -- \/ - ,infixr_ 6 ["/\\"] -- /\ - ] - --- Fixites from the `base` package which are currently --- missing from `haskell-src-exts`'s baseFixities. --- see https://github.com/haskell-suite/haskell-src-exts/pull/400 -baseNotYetInHSE :: [Fixity] -baseNotYetInHSE = concat - [infixr_ 9 ["`Compose`"] - ,infixr_ 6 ["<>"] - ,infixr_ 5 ["<|"] - ,infixl_ 4 ["<$!>","<$","$>"] - ,infix_ 4 [":~:", ":~~:"] - ] - -customFixities :: [Fixity] -customFixities = - infixl_ 1 ["`on`"] - -- see https://github.com/ndmitchell/hlint/issues/425 - -- otherwise GTK apps using `on` at a different fixity have spurious warnings - -- | Default value for 'ParseFlags'. defaultParseFlags :: ParseFlags -defaultParseFlags = ParseFlags NoCpp defaultParseMode - {fixities = Just $ customFixities ++ baseFixities ++ baseNotYetInHSE ++ lensFixities ++ otherFixities - ,ignoreLinePragmas = False - ,ignoreFunctionArity = True - ,extensions = parseExtensions} - -parseFlagsNoLocations :: ParseFlags -> ParseFlags -parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y} - where f x = x{boolopts = (boolopts x){locations=False}} +defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions defaultFixities -- | Given some fixities, add them to the existing fixities in 'ParseFlags'. -parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags -parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}} - where hse = hseFlags x +parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags +parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x} -parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags -parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags x){baseLanguage = l, extensions = es}} +parseFlagsSetLanguage :: (Maybe Language, [Extension]) -> ParseFlags -> ParseFlags +parseFlagsSetLanguage (l, es) x = x{baseLanguage = l, extensions = es} runCpp :: CppFlags -> FilePath -> String -> IO String -runCpp NoCpp _ x = return x -runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x] +runCpp NoCpp _ x = pure x +runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x] runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x where -- LINE pragmas always inserted when locations=True @@ -184,16 +79,14 @@ -- | A parse error. data ParseError = ParseError - { parseErrorLocation :: SrcLoc -- ^ Location of the error. + { parseErrorLocation :: GHC.SrcSpan -- ^ Location of the error. , parseErrorMessage :: String -- ^ Message about the cause of the error. , parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line. } -- | Result of 'parseModuleEx', representing a parsed module. data ModuleEx = ModuleEx { - hseModule :: Module SrcSpanInfo - , hseComments :: [Comment] - , ghcModule :: GHC.Located (HsSyn.HsModule HsSyn.GhcPs) + ghcModule :: GHC.Located (HsModule GhcPs) , ghcAnnotations :: GHC.ApiAnns } @@ -201,48 +94,7 @@ ghcComments :: ModuleEx -> [GHC.Located GHC.AnnotationComment] ghcComments m = concat (Map.elems $ snd (ghcAnnotations m)) --- | Utility called from 'parseModuleEx' and 'hseFailOpParseModuleEx'. -mkMode :: ParseFlags -> String -> ParseMode -mkMode flags file = (hseFlags flags){ parseFilename = file,fixities = Nothing } --- | Error handler dispatcher. Invoked when HSE parsing has failed. -failOpParseModuleEx :: String - -> ParseFlags - -> FilePath - -> String - -> SrcLoc - -> String - -> Maybe (GHC.SrcSpan, ErrUtils.MsgDoc) - -> IO (Either ParseError ModuleEx) -failOpParseModuleEx ppstr flags file str sl msg ghc = - case ghc of - Just err -> - -- GHC error info is available (assumed to have come from a - -- 'PFailed'). We prefer to construct a 'ParseError' value - -- using that. - ghcFailOpParseModuleEx ppstr file str err - Nothing -> - -- No GHC error info provided. This is the traditional approach - -- to handling errors. - hseFailOpParseModuleEx ppstr flags file str sl msg - --- | An error handler of last resort. This is invoked when HSE parsing --- has failed but apparently GHC has not! -hseFailOpParseModuleEx :: String - -> ParseFlags - -> FilePath - -> String - -> SrcLoc - -> String - -> IO (Either ParseError ModuleEx) -hseFailOpParseModuleEx ppstr flags file str sl msg = do - flags <- return $ parseFlagsNoLocations flags - ppstr2 <- runCpp (cppFlags flags) file str - let pe = case parseFileContentsWithMode (mkMode flags file) ppstr2 of - ParseFailed sl2 _ -> context (srcLine sl2) ppstr2 - _ -> context (srcLine sl) ppstr - return $ Left $ ParseError sl msg pe - -- | The error handler invoked when GHC parsing has failed. ghcFailOpParseModuleEx :: String -> FilePath @@ -250,174 +102,95 @@ -> (GHC.SrcSpan, ErrUtils.MsgDoc) -> IO (Either ParseError ModuleEx) ghcFailOpParseModuleEx ppstr file str (loc, err) = do - let sl = - case loc of - GHC.RealSrcSpan r -> - SrcLoc { srcFilename = FastString.unpackFS (GHC.srcSpanFile r) - , srcLine = GHC.srcSpanStartLine r - , srcColumn = GHC.srcSpanStartCol r } - GHC.UnhelpfulSpan _ -> - SrcLoc { srcFilename = file - , srcLine = 1 :: Int - , srcColumn = 1 :: Int } - pe = context (srcLine sl) ppstr - msg = Outputable.showSDoc baseDynFlags $ - ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err) - return $ Left $ ParseError sl msg pe - --- A hacky function to get fixities from HSE parse flags suitable for --- use by our own 'GHC.Util.Refact.Fixity' module. -ghcFixitiesFromParseMode :: ParseMode -> [(String, GHC.Fixity)] -ghcFixitiesFromParseMode 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 _ = "" -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 + let pe = case loc of + GHC.RealSrcSpan r -> context (GHC.srcSpanStartLine r) ppstr + _ -> "" + msg = Outputable.showSDoc baseDynFlags err + pure $ Left $ ParseError loc msg pe -- GHC extensions to enable/disable given HSE parse flags. -ghcExtensionsFromParseFlags :: ParseFlags - -> ([GHC.Extension], [GHC.Extension]) -ghcExtensionsFromParseFlags ParseFlags {hseFlags=mode} = ghcExtensionsFromParseMode mode +ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension]) +ghcExtensionsFromParseFlags ParseFlags{extensions=exts}= (exts, []) -- GHC fixities given HSE parse flags. ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)] -ghcFixitiesFromParseFlags ParseFlags {hseFlags=mode} = ghcFixitiesFromParseMode mode +ghcFixitiesFromParseFlags = map toFixity . fixities -- These next two functions get called frorm 'Config/Yaml.hs' for user -- defined hint rules. -parseExpGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LHsExpr HsSyn.GhcPs) +parseModeToFlags :: ParseFlags -> GHC.DynFlags +parseModeToFlags parseMode = + flip GHC.lang_set (baseLanguage parseMode) $ foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable + where + (enable, disable) = ghcExtensionsFromParseFlags parseMode + +parseExpGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsExpr 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 + let fixities = ghcFixitiesFromParseFlags parseMode + in case parseExpGhcLib s $ parseModeToFlags parseMode of GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a) f@GHC.PFailed{} -> f -parseImportDeclGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LImportDecl HsSyn.GhcPs) +parseImportDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LImportDecl 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 + parseImportGhcLib s $ parseModeToFlags parseMode +parseDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsDecl GhcPs) +parseDeclGhcWithMode parseMode s = + let fixities = ghcFixitiesFromParseFlags parseMode + in case parseDeclGhcLib s $ parseModeToFlags parseMode of + GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a) + f@GHC.PFailed{} -> f + -- | Parse a Haskell module. Applies the C pre processor, and uses -- best-guess fixity resolution if there are ambiguities. The -- filename @-@ is treated as @stdin@. Requires some flags (often -- 'defaultParseFlags'), the filename, and optionally the contents of --- that file. This version uses both hs-src-exts AND ghc-lib. +-- that file. parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx) parseModuleEx flags file str = timedIO "Parse" file $ do str <- case str of - Just x -> return x + Just x -> pure x Nothing | file == "-" -> getContentsUTF8 | otherwise -> readFileUTF8' file - str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130 + str <- pure $ dropPrefix "\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. + fixities = ghcFixitiesFromParseFlags 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), GHC.POk pst a) -> + Right ghcFlags -> do + ghcFlags <- pure $ GHC.lang_set ghcFlags $ baseLanguage flags + case parseFileGhcLib file ppstr ghcFlags of + GHC.POk pst a -> let anns = ( Map.fromListWith (++) $ GHC.annotations pst , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pst) : GHC.annotations_comments pst) ) in let a' = GhclibParserEx.applyFixities fixities a in - return $ Right (ModuleEx (applyFixity fixity x) cs a' anns) + pure $ Right (ModuleEx a' anns) -- Parse error if GHC parsing fails (see -- https://github.com/ndmitchell/hlint/issues/645). - (ParseOk _, GHC.PFailed _ loc err) -> - ghcFailOpParseModuleEx ppstr file str (loc, err) - (ParseFailed sl msg, pfailed) -> - failOpParseModuleEx ppstr flags file str sl msg $ fromPFailed pfailed + GHC.PFailed s -> do + let (_, errs) = GHC.getMessages s ghcFlags + errMsg = head (bagToList errs) + loc = errMsgSpan errMsg + doc = formatErrDoc ghcFlags (errMsgDoc errMsg) + ghcFailOpParseModuleEx ppstr file str (loc, doc) Left msg -> do -- Parsing GHC flags from dynamic pragmas in the source -- has failed. When this happens, it's reported by -- exception. It's impossible or at least fiddly getting a -- location so we skip that for now. Synthesize a parse -- error. - let loc = SrcLoc file (1 :: Int) (1 :: Int) - return $ Left (ParseError loc msg (context (srcLine loc) ppstr)) + let loc = GHC.mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int) + pure $ Left (ParseError (GHC.mkSrcSpan loc loc) msg ppstr) - where - fromPFailed (GHC.PFailed _ loc err) = Just (loc, err) - fromPFailed _ = Nothing - fixity = fromMaybe [] $ fixities $ hseFlags flags - -- | Given a line number, and some source code, put bird ticks around the appropriate bit. context :: Int -> String -> String context lineNo src = unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $ zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""] - where ticks = [" "," ","> "," "," "] - - ---------------------------------------------------------------------- --- FIXITIES - --- resolve fixities later, so we don't ever get uncatchable ambiguity errors --- if there are fixity errors, try the cheapFixities (which never fails) -applyFixity :: [Fixity] -> Module_ -> Module_ -applyFixity base modu = descendBi f modu - where - f x = fromMaybe (cheapFixities fixs x) $ applyFixities fixs x :: Decl_ - fixs = concatMap getFixity (moduleDecls modu) ++ base - - --- Apply fixities, but ignoring any ambiguous fixity errors and skipping qualified names, --- local infix declarations etc. Only use as a backup, if HSE gives an error. --- --- Inspired by the code at: --- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs -cheapFixities :: [Fixity] -> Decl_ -> Decl_ -cheapFixities fixs = descendBi (transform f) - where - ask = askFixity fixs - - f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z) - | p1 == p2 && (a1 /= a2 || isAssocNone a1) = o -- Ambiguous infix expression! - | p1 > p2 || p1 == p2 && (isAssocLeft a1 || isAssocNone a2) = o - | otherwise = InfixApp s1 x op1 (f $ InfixApp s1 y op2 z) - where - (a1,p1) = ask op1 - (a2,p2) = ask op2 - f x = x - - -askFixity :: [Fixity] -> QOp S -> (Assoc (), Int) -askFixity xs = \k -> Map.findWithDefault (AssocLeft (), 9) (fromNamed k) mp - where - mp = Map.fromList [(s,(a,p)) | Fixity a p x <- xs, let s = fromNamed $ fmap (const an) x, s /= ""] + where ticks = drop (3 - lineNo) [" "," ","> "," "," "] diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs deleted file mode 100644 --- a/src/HSE/Match.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} - -module HSE.Match( - View(..), Named(..), - (~=), isSym, - App2(App2), PVar_(PVar_), Var_(Var_) - ) where - -import Data.Char -import HSE.Type -import HSE.Util - - -class View a b where - view :: a -> b - - -data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show - -instance View Exp_ App2 where - view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs - view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y - view _ = NoApp2 - - -data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show - -instance View Exp_ App1 where - view (fromParen -> App _ f x) = App1 f x - view _ = NoApp1 - -data PVar_ = NoPVar_ | PVar_ String - -instance View Pat_ PVar_ where - view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x - view _ = NoPVar_ - -data Var_ = NoVar_ | Var_ String deriving Eq - -instance View Exp_ Var_ where - view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x - view _ = NoVar_ - - -(~=) :: Named a => a -> String -> Bool -(~=) = (==) . fromNamed - - --- | fromNamed will return \"\" when it cannot be represented --- toNamed may crash on \"\" -class Named a where - toNamed :: String -> a - fromNamed :: a -> String - - -isCtor (x:_) = isUpper x || x == ':' -isCtor _ = False - -isSym (x:_) = not $ isAlpha x || x `elem` "_'" -isSym _ = False - - -instance Named (Exp S) where - fromNamed (Var _ x) = fromNamed x - fromNamed (Con _ x) = fromNamed x - fromNamed (List _ []) = "[]" - fromNamed _ = "" - - toNamed "[]" = List an [] - toNamed x | isCtor x = Con an $ toNamed x - | otherwise = Var an $ toNamed x - -instance Named (QName S) where - fromNamed (Special _ Cons{}) = ":" - fromNamed (Special _ UnitCon{}) = "()" - fromNamed (UnQual _ x) = fromNamed x - fromNamed _ = "" - - toNamed ":" = Special an $ Cons an - toNamed x = UnQual an $ toNamed x - -instance Named (Name S) where - fromNamed (Ident _ x) = x - fromNamed (Symbol _ x) = x - - toNamed x | isSym x = Symbol an x - | otherwise = Ident an x - -instance Named (ModuleName S) where - fromNamed (ModuleName _ x) = x - toNamed = ModuleName an - - -instance Named (Pat S) where - fromNamed (PVar _ x) = fromNamed x - fromNamed (PApp _ x []) = fromNamed x - fromNamed (PList _ []) = "[]" - fromNamed _ = "" - - toNamed x | isCtor x = PApp an (toNamed x) [] - | otherwise = PVar an $ toNamed x - - -instance Named (TyVarBind S) where - fromNamed (KindedVar _ x _) = fromNamed x - fromNamed (UnkindedVar _ x) = fromNamed x - toNamed x = UnkindedVar an (toNamed x) - - -instance Named (QOp S) where - fromNamed (QVarOp _ x) = fromNamed x - fromNamed (QConOp _ x) = fromNamed x - toNamed x | isCtor x = QConOp an $ toNamed x - | otherwise = QVarOp an $ toNamed x - -instance Named (Match S) where - fromNamed (Match _ x _ _ _) = fromNamed x - fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x - toNamed = error "No toNamed for Match" - -instance Named (DeclHead S) where - fromNamed (DHead _ x) = fromNamed x - fromNamed (DHInfix _ _ x) = fromNamed x - fromNamed (DHParen _ x) = fromNamed x - fromNamed (DHApp _ x _) = fromNamed x - toNamed = error "No toNamed for DeclHead" - -instance Named (Decl S) where - fromNamed (TypeDecl _ name _) = fromNamed name - fromNamed (DataDecl _ _ _ name _ _) = fromNamed name - fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name - fromNamed (TypeFamDecl _ name _ _) = fromNamed name - fromNamed (DataFamDecl _ _ name _) = fromNamed name - fromNamed (ClassDecl _ _ name _ _) = fromNamed name - fromNamed (PatBind _ (PVar _ name) _ _) = fromNamed name - fromNamed (FunBind _ (name:_)) = fromNamed name - fromNamed (ForImp _ _ _ _ name _) = fromNamed name - fromNamed (ForExp _ _ _ name _) = fromNamed name - fromNamed (TypeSig _ (name:_) _) = fromNamed name - fromNamed _ = "" - - toNamed = error "No toNamed for Decl" diff --git a/src/HSE/Scope.hs b/src/HSE/Scope.hs deleted file mode 100644 --- a/src/HSE/Scope.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module HSE.Scope( - Scope, scopeCreate, scopeImports - ) where - -import Data.Semigroup -import HSE.Type -import HSE.Util -import Data.List -import Data.Maybe -import Prelude - -{- -the hint file can do: - -import Prelude (filter) -import Data.List (filter) -import List (filter) - -then filter on it's own will get expanded to all of them - -import Data.List -import List as Data.List - - -if Data.List.head x ==> x, then that might match List too --} - - --- | Data type representing the modules in scope within a module. --- Created with 'scopeCreate' and queried with 'scopeMatch' and 'scopeMove'. --- Note that the 'mempty' 'Scope' is not equivalent to 'scopeCreate' on an empty module, --- due to the implicit import of 'Prelude'. -newtype Scope = Scope [ImportDecl S] - deriving (Show, Monoid, Semigroup) - --- | Create a 'Scope' value from a module, based on the modules imports. -scopeCreate :: Module SrcSpanInfo -> Scope -scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res - where - res = [x | x <- moduleImports xs, importPkg x /= Just "hint"] - prelude = ImportDecl an (ModuleName an "Prelude") False False False Nothing Nothing Nothing - isPrelude x = fromModuleName (importModule x) == "Prelude" - - -scopeImports :: Scope -> [ImportDecl S] -scopeImports (Scope x) = x diff --git a/src/HSE/Type.hs b/src/HSE/Type.hs deleted file mode 100644 --- a/src/HSE/Type.hs +++ /dev/null @@ -1,18 +0,0 @@ - -module HSE.Type( - S, - Module_, Decl_, Exp_, Pat_, - module HSE, - module Uniplate - ) where - --- Almost all from the Annotated module, but the fixity resolution from Annotated --- uses the unannotated Assoc enumeration, so export that instead -import Language.Haskell.Exts as HSE hiding (parse, loc, paren) -import Data.Generics.Uniplate.Data as Uniplate - -type S = SrcSpanInfo -type Module_ = Module S -type Decl_ = Decl S -type Exp_ = Exp S -type Pat_ = Pat S diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs deleted file mode 100644 --- a/src/HSE/Util.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TupleSections #-} - -module HSE.Util(module HSE.Util, def) where - -import Control.Monad -import Data.Default -import Data.Tuple.Extra -import Data.List -import Language.Haskell.Exts.Util -import Control.Monad.Trans.State -import qualified Data.Map as Map -import Data.Maybe -import Data.Data hiding (Fixity) -import System.FilePath -import HSE.Type -import Data.Functor -import Prelude - - ---------------------------------------------------------------------- --- ACCESSOR/TESTER - -ellipses :: QName S -ellipses = UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol - -opExp :: QOp S -> Exp_ -opExp (QVarOp s op) = Var s op -opExp (QConOp s op) = Con s op - -expOp :: Exp_ -> Maybe (QOp S) -expOp (Var s op) = Just $ QVarOp s op -expOp (Con s op) = Just $ QConOp s op -expOp _ = Nothing - -moduleDecls :: Module_ -> [Decl_] -moduleDecls (Module _ _ _ _ xs) = xs -moduleDecls _ = [] -- XmlPage/XmlHybrid - -moduleName :: Module_ -> String -moduleName (Module _ Nothing _ _ _) = "Main" -moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x -moduleName _ = "" -- XmlPage/XmlHybrid - -moduleImports :: Module_ -> [ImportDecl S] -moduleImports (Module _ _ _ x _) = x -moduleImports _ = [] -- XmlPage/XmlHybrid - -modulePragmas :: Module_ -> [ModulePragma S] -modulePragmas (Module _ _ x _ _) = x -modulePragmas _ = [] -- XmlPage/XmlHybrid - -moduleExtensions :: Module_ -> [Name S] -moduleExtensions x = concat [y | LanguagePragma _ y <- modulePragmas x] - -fromModuleName :: ModuleName S -> String -fromModuleName (ModuleName _ x) = x - -fromChar :: Exp_ -> Maybe Char -fromChar (Lit _ (Char _ x _)) = Just x -fromChar _ = Nothing - -fromPChar :: Pat_ -> Maybe Char -fromPChar (PLit _ _ (Char _ x _)) = Just x -fromPChar _ = Nothing - -fromString :: Exp_ -> Maybe String -fromString (Lit _ (String _ x _)) = Just x -fromString _ = Nothing - -fromPString :: Pat_ -> Maybe String -fromPString (PLit _ _ (String _ x _)) = Just x -fromPString _ = Nothing - -fromParen1 :: Exp_ -> Exp_ -fromParen1 (Paren _ x) = x -fromParen1 x = x - -fromParen :: Exp_ -> Exp_ -fromParen (Paren _ x) = fromParen x -fromParen x = x - -fromPParen :: Pat s -> Pat s -fromPParen (PParen _ x) = fromPParen x -fromPParen x = x - -fromTyParen :: Type s -> Type s -fromTyParen (TyParen _ x) = fromTyParen x -fromTyParen x = x - -fromTyBang :: Type s -> Type s -fromTyBang (TyBang _ _ _ x) = x -fromTyBang x = x - --- is* :: Exp_ -> Bool --- is* :: Decl_ -> Bool -isVar Var{} = True; isVar _ = False -isCon Con{} = True; isCon _ = False -isApp App{} = True; isApp _ = False -isInfixApp InfixApp{} = True; isInfixApp _ = False -isAnyApp x = isApp x || isInfixApp x -isParen Paren{} = True; isParen _ = False -isIf If{} = True; isIf _ = False -isLambda Lambda{} = True; isLambda _ = False -isMDo MDo{} = True; isMDo _ = False -isBoxed Boxed{} = True; isBoxed _ = False -isDerivDecl DerivDecl{} = True; isDerivDecl _ = False -isPBangPat PBangPat{} = True; isPBangPat _ = False -isPFieldPun PFieldPun{} = True; isPFieldPun _ = False -isFieldPun FieldPun{} = True; isFieldPun _ = False -isPWildCard PWildCard{} = True; isPWildCard _ = False -isPFieldWildcard PFieldWildcard{} = True; isPFieldWildcard _ = False -isFieldWildcard FieldWildcard{} = True; isFieldWildcard _ = False -isPViewPat PViewPat{} = True; isPViewPat _ = False -isParComp ParComp{} = True; isParComp _ = False -isTypeApp TypeApp{} = True; isTypeApp _ = False -isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False -isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False -isTyQuasiQuote TyQuasiQuote{} = True; isTyQuasiQuote _ = False -isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False -isNewType NewType{} = True; isNewType _ = False -isRecStmt RecStmt{} = True; isRecStmt _ = False -isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False -isTyBang TyBang{} = True; isTyBang _ = False -isLCase LCase{} = True; isLCase _ = False -isTupleSection TupleSection{} = True; isTupleSection _ = False -isString String{} = True; isString _ = False -isRecUpdate RecUpdate{} = True; isRecUpdate _ = False -isRecConstr RecConstr{} = True; isRecConstr _ = False - -isSection LeftSection{} = True -isSection RightSection{} = True -isSection _ = False - -isPrimLiteral PrimInt{} = True -isPrimLiteral PrimWord{} = True -isPrimLiteral PrimFloat{} = True -isPrimLiteral PrimDouble{} = True -isPrimLiteral PrimChar{} = True -isPrimLiteral PrimString{} = True -isPrimLiteral _ = False - - -allowRightSection x = x `notElem` ["-","#"] -allowLeftSection x = x /= "#" - - -unqual :: QName S -> QName S -unqual (Qual an _ x) = UnQual an x -unqual x = x - -fromQual :: QName a -> Maybe (Name a) -fromQual (Qual _ _ x) = Just x -fromQual (UnQual _ x) = Just x -fromQual _ = Nothing - -isSpecial :: QName S -> Bool -isSpecial Special{} = True; isSpecial _ = False - -isDol :: QOp S -> Bool -isDol (QVarOp _ (UnQual _ (Symbol _ "$"))) = True -isDol _ = False - -isDot :: QOp S -> Bool -isDot (QVarOp _ (UnQual _ (Symbol _ "."))) = True -isDot _ = False - -isDotApp :: Exp_ -> Bool -isDotApp (InfixApp _ _ dot _) | isDot dot = True -isDotApp _ = False - -dotApp :: Exp_ -> Exp_ -> Exp_ -dotApp x = InfixApp an x (QVarOp an $ UnQual an $ Symbol an ".") - -dotApps :: [Exp_] -> Exp_ -dotApps [] = error "HSE.Util.dotApps, does not work on an empty list" -dotApps [x] = x -dotApps (x:xs) = dotApp x (dotApps xs) - -isReturn :: Exp_ -> Bool --- Allow both pure and return, as they have the same semantics -isReturn (Var _ (UnQual _ (Ident _ x))) = x == "return" || x == "pure" -isReturn _ = False - -isLexeme Var{} = True -isLexeme Con{} = True -isLexeme Lit{} = True -isLexeme _ = False - -isAssocLeft AssocLeft{} = True; isAssocLeft _ = False -isAssocNone AssocNone{} = True; isAssocNone _ = False - -isWHNF :: Exp_ -> Bool -isWHNF Con{} = True -isWHNF (Lit _ x) = case x of String{} -> False; Int{} -> False; Frac{} -> False; _ -> True -isWHNF Lambda{} = True -isWHNF Tuple{} = True -isWHNF List{} = True -isWHNF (Paren _ x) = isWHNF x -isWHNF (ExpTypeSig _ x _) = isWHNF x --- other (unknown) constructors may have bang patterns in them, so approximate -isWHNF (App _ c@Con{} _) | prettyPrint c `elem` ["Just","Left","Right"] = True -isWHNF _ = False - - --- | Like needBracket, but with a special case for a . b . b, which --- was removed from haskell-src-exts-util-0.2.2 -needBracketOld :: Int -> Exp_ -> Exp_ -> Bool -needBracketOld i parent child - | isDotApp parent, isDotApp child, i == 1 = False - | otherwise = needBracket i parent child - -transformBracketOld :: (Exp_ -> Maybe Exp_) -> Exp_ -> Exp_ -transformBracketOld op = snd . g - where - g = f . descendBracketOld g - f x = maybe (False,x) (True,) (op x) - --- | Descend, and if something changes then add/remove brackets appropriately -descendBracketOld :: (Exp_ -> (Bool, Exp_)) -> Exp_ -> Exp_ -descendBracketOld op x = descendIndex g x - where - g i y = if a then f i b else b - where (a,b) = op y - - f i (Paren _ y) | not $ needBracketOld i x y = y - f i y | needBracketOld i x y = addParen y - f _ y = y - -descendIndex :: Data a => (Int -> a -> a) -> a -> a -descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do - i <- get - modify (+1) - return $ f i y - - ---------------------------------------------------------------------- --- HSE FUNCTIONS - -getEquations :: Decl s -> [Decl s] -getEquations (FunBind s xs) = map (FunBind s . (:[])) xs -getEquations x@PatBind{} = [toFunBind x] -getEquations x = [x] - - -toFunBind :: Decl s -> Decl s -toFunBind (PatBind s (PVar _ name) bod bind) = FunBind s [Match s name [] bod bind] -toFunBind x = x - - --- case and if both have branches, nothing else does -replaceBranches :: Exp s -> ([Exp s], [Exp s] -> Exp s) -replaceBranches (If s a b c) = ([b,c], \[b,c] -> If s a b c) -replaceBranches (Case s a bs) = (concatMap f bs, Case s a . g bs) - where - f (Alt _ _ (UnGuardedRhs _ x) _) = [x] - f (Alt _ _ (GuardedRhss _ xs) _) = [x | GuardedRhs _ _ x <- xs] - g (Alt s1 a (UnGuardedRhs s2 _) b:rest) (x:xs) = Alt s1 a (UnGuardedRhs s2 x) b : g rest xs - g (Alt s1 a (GuardedRhss s2 ns) b:rest) xs = - Alt s1 a (GuardedRhss s2 [GuardedRhs a b x | (GuardedRhs a b _,x) <- zip ns as]) b : g rest bs - where (as,bs) = splitAt (length ns) xs - g [] [] = [] - g _ _ = error "HSE.Util.replaceBranches: internal invariant failed, lists are of differing lengths" -replaceBranches x = ([], \[] -> x) - - ---------------------------------------------------------------------- --- VECTOR APPLICATION - - -apps :: [Exp_] -> Exp_ -apps = foldl1 (App an) - -fromApps :: Exp_ -> [Exp_] -fromApps = map fst . fromAppsWithLoc - -fromAppsWithLoc :: Exp_ -> [(Exp_, S)] -fromAppsWithLoc (App l x y) = fromAppsWithLoc x ++ [(y, l)] -fromAppsWithLoc x = [(x, ann x)] - - --- Rule for the Uniplate Apps functions --- Given (f a) b, consider the children to be: children f ++ [a,b] - -childrenApps :: Exp_ -> [Exp_] -childrenApps (App s x y) = childrenApps x ++ [y] -childrenApps x = children x - - -descendApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_ -descendApps f (App s x y) = App s (descendApps f x) (f y) -descendApps f x = descend f x - - -descendAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ -descendAppsM f (App s x y) = liftM2 (App s) (descendAppsM f x) (f y) -descendAppsM f x = descendM f x - - -universeApps :: Exp_ -> [Exp_] -universeApps x = x : concatMap universeApps (childrenApps x) - -transformApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_ -transformApps f = f . descendApps (transformApps f) - -transformAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ -transformAppsM f x = f =<< descendAppsM (transformAppsM f) x - - ---------------------------------------------------------------------- --- UNIPLATE FUNCTIONS - -universeS :: (Data x, Data (f S)) => x -> [f S] -universeS = universeBi - -childrenS :: (Data x, Data (f S)) => x -> [f S] -childrenS = childrenBi - - --- return the parent along with the child -universeParentExp :: Data a => a -> [(Maybe (Int, Exp_), Exp_)] -universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs] - where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p] - - ---------------------------------------------------------------------- --- SRCLOC FUNCTIONS - -showSrcLoc :: SrcLoc -> String -showSrcLoc (SrcLoc file line col) = take 1 file ++ f (drop 1 file) ++ ":" ++ show line ++ ":" ++ show col - where f (x:y:zs) | isPathSeparator x && isPathSeparator y = f $ x:zs - f (x:xs) = x : f xs - f [] = [] - -an :: SrcSpanInfo -an = def - -dropAnn :: Functor f => f SrcSpanInfo -> f () -dropAnn = void - ---------------------------------------------------------------------- --- SRCLOC EQUALITY - --- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor - -x /=~= y = not $ x =~= y - -elem_, notElem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool -elem_ x = any (x =~=) -notElem_ x = not . elem_ x - -nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -nub_ = nubBy (=~=) - -delete_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> [f S] -delete_ = deleteBy (=~=) - -intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S] -intersect_ = intersectBy (=~=) - -eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool -neqList x y = not $ eqList x y -eqList (x:xs) (y:ys) = x =~= y && eqList xs ys -eqList [] [] = True -eqList _ _ = False - -eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool -eqMaybe (Just x) (Just y) = x =~= y -eqMaybe Nothing Nothing = True -eqMaybe _ _ = False - - ---------------------------------------------------------------------- --- FIXITIES - -getFixity :: Decl a -> [Fixity] -getFixity (InfixDecl sl a mp ops) = [Fixity (void a) (fromMaybe 9 mp) (UnQual () $ void $ f op) | op <- ops] - where f (VarOp _ x) = x - f (ConOp _ x) = x -getFixity _ = [] - -toInfixDecl :: Fixity -> Decl () -toInfixDecl (Fixity a b c) = InfixDecl () a (Just b) $ maybeToList $ VarOp () <$> fromQual c - - - --- | This extension implies the following extensions -extensionImplies :: Extension -> [Extension] -extensionImplies = \x -> Map.findWithDefault [] x mp - where mp = Map.fromList extensionImplications - --- | This extension is implied by the following extensions -extensionImpliedBy :: Extension -> [Extension] -extensionImpliedBy = \x -> Map.findWithDefault [] x mp - where mp = Map.fromListWith (++) [(b, [a]) | (a,bs) <- extensionImplications, b <- bs] - --- | (a, bs) means extension a implies all of bs. --- Taken from https://downloads.haskell.org/~ghc/master/users-guide/glasgow_exts.html#language-options --- In the GHC source at DynFlags.impliedXFlags -extensionImplications :: [(Extension, [Extension])] -extensionImplications = map (first EnableExtension) $ - (RebindableSyntax, [DisableExtension ImplicitPrelude]) : - map (second (map EnableExtension)) - [ (DerivingVia , [DerivingStrategies]) - , (RecordWildCards , [DisambiguateRecordFields]) - , (ExistentialQuantification, [ExplicitForAll]) - , (FlexibleInstances , [TypeSynonymInstances]) - , (FunctionalDependencies , [MultiParamTypeClasses]) - , (GADTs , [MonoLocalBinds]) - , (IncoherentInstances , [OverlappingInstances]) --- Incorrect, see https://github.com/ndmitchell/hlint/issues/587 --- , (ImplicitParams , [FlexibleContexts, FlexibleInstances]) - , (ImpredicativeTypes , [ExplicitForAll, RankNTypes]) - , (LiberalTypeSynonyms , [ExplicitForAll]) - , (PolyKinds , [KindSignatures]) - , (RankNTypes , [ExplicitForAll]) - , (ScopedTypeVariables , [ExplicitForAll]) - , (TypeOperators , [ExplicitNamespaces]) - , (TypeFamilies , [ExplicitNamespaces, KindSignatures, MonoLocalBinds]) - , (TypeFamilyDependencies , [ExplicitNamespaces, KindSignatures, MonoLocalBinds, TypeFamilies]) - ] diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -1,6 +1,6 @@ module Hint.All( - Hint(..), DeclHint, ModuHint, + Hint(..), ModuHint, resolveHints, hintRules, builtinHints ) where @@ -44,41 +44,38 @@ builtin :: HintBuiltin -> Hint builtin x = case x of - -- Hse. - HintLambda -> decl lambdaHint - -- Ghc. + HintLambda -> decl lambdaHint HintImport -> modu importHint HintExport -> modu exportHint HintComment -> modu commentHint HintPragma -> modu pragmaHint HintDuplicate -> mods duplicateHint HintRestrict -> mempty{hintModule=restrictHint} - HintList -> decl' listHint - HintNewType -> decl' newtypeHint - HintUnsafe -> decl' unsafeHint - HintListRec -> decl' listRecHint - HintNaming -> decl' namingHint - HintBracket -> decl' bracketHint - HintSmell -> mempty{hintDecl'=smellHint,hintModule=smellModuleHint} - HintPattern -> decl' patternHint - HintMonad -> decl' monadHint + HintList -> decl listHint + HintNewType -> decl newtypeHint + HintUnsafe -> decl unsafeHint + HintListRec -> decl listRecHint + HintNaming -> decl namingHint + HintBracket -> decl bracketHint + HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint} + HintPattern -> decl patternHint + HintMonad -> decl monadHint HintExtensions -> modu extensionsHint where wrap = timed "Hint" (drop 4 $ show x) . forceList decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c} - decl' f = mempty{hintDecl'=const $ \a b c -> wrap $ f a b c} modu f = mempty{hintModule=const $ \a b -> wrap $ f a b} mods f = mempty{hintModules=const $ \a -> wrap $ f a} -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)] -builtinHints = [(drop 4 $ show h, builtin h) | h <- [minBound .. maxBound]] +builtinHints = [(drop 4 $ show h, builtin h) | h <- enumerate] -- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'. resolveHints :: [Either HintBuiltin HintRule] -> Hint resolveHints xs = - mconcat $ mempty{hintDecl'=const $ readMatch' rights} : map builtin (nubOrd lefts) + mconcat $ mempty{hintDecl=const $ readMatch' rights} : map builtin (nubOrd lefts) where (lefts,rights) = partitionEithers xs -- | Transform a list of 'HintRule' into a 'Hint'. diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -35,6 +35,11 @@ yes = (($1)) -- @Warning ($1) no = (+5) yes = ((+5)) -- @Warning (+5) +issue909 = case 0 of { _ | n <- (0 :: Int) -> n } +issue909 = foo (\((x :: z) -> y) -> 9 + x * 7) +issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7 +issue909 = let ((x:: y) -> z) = q in q +issue909 = do {((x :: y) -> z) <- e; return 1} -- type bracket reduction foo :: (Int -> Int) -> Int @@ -51,11 +56,12 @@ -- dollar reduction tests no = groupFsts . sortFst $ mr -yes = split "to" $ names -- split "to" names -yes = white $ keysymbol -- white keysymbol -yes = operator foo $ operator -- operator foo operator +yes = split "to" $ names -- +yes = white $ keysymbol -- +yes = operator foo $ operator -- no = operator foo $ operator bar yes = return $ Record{a=b} +no = f $ [1,2..5] -- @NoRefactor: apply-refact bug; see apply-refact #51 -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e @@ -68,7 +74,7 @@ main = do a += b . c; return $ a . b -- <$> bracket tests -yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q +yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q @NoRefactor: refactoring for "(v1 . v2) <$> v3" is not implemented no = foo . bar x <$> baz q -- annotations @@ -89,12 +95,13 @@ module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',Severity(..),toSS') +import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',suggestRemove,Severity(..),toSS') import Data.Data +import Data.List.Extra import Data.Generics.Uniplate.Operations import Refact.Types -import HsSyn +import GHC.Hs import Outputable import SrcLoc import GHC.Util @@ -104,13 +111,13 @@ bracketHint _ _ 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 (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LPat GhcPs]) ++ concatMap fieldDecl (childrenBi x) where -- Brackets the roots of annotations are fine, so we strip them. annotations :: AnnDecl GhcPs -> AnnDecl GhcPs annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of - LL l (HsPar _ x) -> x + L l (HsPar _ x) -> x x -> x -- If we find ourselves in the context of a section and we want to @@ -120,8 +127,8 @@ -- 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 s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs) +prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs) prettyExpr x = unsafePrettyPrint x -- Dirty, should add to Brackets type class I think @@ -144,8 +151,8 @@ 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 (L _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True +isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True isPartialAtom x = isRecConstr x || isRecUpdate x bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea] @@ -183,7 +190,7 @@ 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] + g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o] bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea bracketWarning msg o x = @@ -194,8 +201,8 @@ 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 +fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) = + let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in [rawIdea' Suggestion "Redundant bracket" loc (showSDocUnsafe $ ppr_fld o) -- Note this custom printer! (Just (showSDocUnsafe $ ppr_fld r)) @@ -206,10 +213,9 @@ -- 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_fld (L _ 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 #-}' + ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n ppr_names ns = sep (punctuate comma (map ppr ns)) @@ -220,26 +226,26 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe 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 + f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d + , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs , not $ needBracket' 0 y a , not $ needBracket' 1 y b , 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 + |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x , isDol op1 , isVar a1 || isApp a1 || isPar a1, not $ isAtom' a2 , varToStr a1 /= "select" -- special case for esqueleto, see #224 - , let y = noLoc $ HsApp noExt a1 (noLoc (HsPar noExt a2)) + , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2)) , let r = Replace Expr (toSS' e) [("a", toSS' a1), ("b", toSS' a2)] "a (b)" ] ++ -- Special case of (v1 . v2) <$> v3 [ suggest' "Redundant bracket" x y [] - | 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] + | L _ (OpApp _ (L _ (HsPar _ o1@(L _ (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>" + , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs] 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 (L l (OpApp _ lhs op rhs)) = + [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField 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 @@ -38,7 +38,7 @@ where isMultiline = isCommentMultiline comm s = commentText comm - name = takeWhile (\x -> isAlphaNum x || x == '_') $ dropWhile isSpace s + name = takeWhile (\x -> isAlphaNum x || x == '_') $ trimStart s chk _ = [] grab :: String -> Located AnnotationComment -> String -> Idea @@ -46,4 +46,4 @@ let s1 = commentText o in 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)] + refact = [ModifyComment (toRefactSrcSpan' 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 @@ -7,22 +7,22 @@ main = do a; a; a; a -main = do a; a; a; a; a; a -- ??? -main = do a; a; a; a; a; a; a -- ??? -main = do (do b; a; a; a); do (do c; a; a; a) -- ??? -main = do a; a; a; b; a; a; a -- ??? +main = do a; a; a; a; a; a -- ??? @NoRefactor: refactoring not supported for duplication hints. +main = do a; a; a; a; a; a; a -- ??? @NoRefactor +main = do (do b; a; a; a); do (do c; a; a; a) -- ??? @NoRefactor +main = do a; a; a; b; a; a; a -- ??? @NoRefactor main = do a; a; a; b; a; a -foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ??? -{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? -{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? -{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? +foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ??? @NoRefactor +{-# ANN main "HLint: ignore Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor +{-# HLINT ignore main "Reduce duplication" #-}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor +{- HLINT ignore main "Reduce duplication" -}; main = do a; a; a; a; a; a -- @Ignore ??? @NoRefactor -} module Hint.Duplicate(duplicateHint) where -import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning),showSrcLoc,ghcSrcLocToHSE) +import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning)) import Data.Data import Data.Generics.Uniplate.Operations import Data.Default @@ -32,7 +32,7 @@ import qualified Data.Map as Map import SrcLoc -import HsSyn +import GHC.Hs import Outputable import Bag import GHC.Util @@ -43,7 +43,7 @@ -- Do expressions. dupes [ (m, d, y) | (m, d, x) <- ds - , HsDo _ _ (LL _ y) :: HsExpr GhcPs <- universeBi x + , HsDo _ _ (L _ y) :: HsExpr GhcPs <- universeBi x ] ++ -- Bindings in a 'let' expression or a 'where' clause. dupes [ (m, d, y) @@ -53,7 +53,7 @@ ] where ds = [(modName m, fromMaybe "" (declName d), unLoc d) - | ModuleEx _ _ m _ <- map snd ms + | ModuleEx m _ <- map snd ms , d <- hsmodDecls (unLoc m)] dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea] @@ -62,8 +62,8 @@ (if length xs >= 5 then Hint.Type.Warning else Suggestion) "Reduce duplication" p1 (unlines $ map unsafePrettyPrint xs) - (Just $ "Combine with " ++ - showSrcLoc (ghcSrcLocToHSE (srcSpanStart p2))) [] + (Just $ "Combine with " ++ showSrcSpan' p2) + [] ){ideaModule = [m1, m2], ideaDecl = [d1, d2]} | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys] where diff --git a/src/Hint/Export.hs b/src/Hint/Export.hs --- a/src/Hint/Export.hs +++ b/src/Hint/Export.hs @@ -3,10 +3,10 @@ main = 1 -module Foo where foo = 1 -- module Foo(module Foo) where +module Foo where foo = 1 -- module Foo(module Foo) where @NoRefactor module Foo(foo) where foo = 1 -module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where -module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where +module Foo(module Foo) where foo = 1 -- @Ignore module Foo(...) where @NoRefactor +module Foo(module Foo, foo) where foo = 1 -- module Foo(..., foo) where @NoRefactor -} {-# LANGUAGE TypeFamilies #-} @@ -15,33 +15,33 @@ import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore',Note(..)) -import HsSyn +import GHC.Hs import Module import SrcLoc import OccName import RdrName exportHint :: ModuHint -exportHint _ (ModuleEx _ _ (LL s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _) +exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _) | Nothing <- exports = - let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExt name)] )} in + let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in [(ignore' "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}] | Just (L _ xs) <- exports , mods <- [x | x <- xs, isMod x] , modName <- moduleNameString (unLoc name) - , names <- [ moduleNameString (unLoc n) | (LL _ (IEModuleContents _ n)) <- mods] + , names <- [ moduleNameString (unLoc n) | (L _ (IEModuleContents _ n)) <- mods] , exports' <- [x | x <- xs, not (matchesModName modName x)] , modName `elem` names = let dots = mkRdrUnqual (mkVarOcc " ... ") - r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExt (noLoc (IEName (noLoc dots)))) : exports') )} + r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )} in [ignore' "Use explicit module export list" (L s o) (noLoc r) []] where o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing } - isMod (LL _ (IEModuleContents _ _)) = True + isMod (L _ (IEModuleContents _ _)) = True isMod _ = False - matchesModName m (LL _ (IEModuleContents _ (L _ n))) = moduleNameString n == m + matchesModName m (L _ (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 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase, NamedFieldPuns #-} {- Suggest removal of unnecessary extensions @@ -33,6 +33,33 @@ foo x = let !y = x in y {-# LANGUAGE BangPatterns #-} \ data Foo = Foo !Int -- +{-# LANGUAGE TypeOperators #-} \ +data (<+>) a b = Foo a b +{-# LANGUAGE TypeOperators #-} \ +data Foo a b = a :+ b -- +{-# LANGUAGE TypeOperators #-} \ +type (<+>) a b = Foo a b +{-# LANGUAGE TypeOperators #-} \ +type Foo a b = a :+ b +{-# LANGUAGE TypeOperators, TypeFamilies #-} \ +type family Foo a b :: Type where Foo a b = a :+ b +{-# LANGUAGE TypeOperators, TypeFamilies #-} \ +type family Foo a b :: Type where Foo a b = (<+>) a b -- {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators, TypeFamilies #-} \ +class Foo a where data (<+>) a +{-# LANGUAGE TypeOperators, TypeFamilies #-} \ +class Foo a where foo :: a -> Int <+> Bool +{-# LANGUAGE TypeOperators #-} \ +class (<+>) a where +{-# LANGUAGE TypeOperators #-} \ +foo :: Int -> Double <+> Bool \ +foo x = y +{-# LANGUAGE TypeOperators #-} \ +foo :: Int -> (<+>) Double Bool \ +foo x = y -- +{-# LANGUAGE TypeOperators #-} \ +(<+>) :: Int -> Int -> Int \ +x <+> y = x + y -- {-# LANGUAGE RecordWildCards #-} \ record field = Record{..} {-# LANGUAGE RecordWildCards #-} \ @@ -78,6 +105,13 @@ f x = case x of (# a, b #) -> a {-# LANGUAGE GeneralizedNewtypeDeriving,UnboxedTuples #-} \ newtype T m a = T (m a) deriving (PrimMonad) +{-# LANGUAGE InstanceSigs #-} \ +instance Eq a => Eq (T a) where \ + (==) :: T a -> T a -> Bool \ + (==) (T x) (T y) = x==y +{-# LANGUAGE InstanceSigs #-} \ +instance Eq a => Eq (T a) where \ + (==) (T x) (T y) = x==y -- {-# LANGUAGE DefaultSignatures #-} \ class Val a where; val :: a -- {-# LANGUAGE DefaultSignatures #-} \ @@ -135,33 +169,64 @@ data Set (cxt :: * -> *) a = Set [a] -- @Note Extension KindSignatures is implied by PolyKinds {-# LANGUAGE QuasiQuotes, OverloadedStrings #-} \ main = putStrLn [f|{T.intercalate "blah" []}|] +{-# LANGUAGE NamedFieldPuns #-} \ +foo = x{bar} +{-# LANGUAGE PatternSynonyms #-} \ +module Foo (pattern Bar) where x = 42 +{-# LANGUAGE PatternSynonyms #-} \ +import Foo (pattern Bar); x = 42 +{-# LANGUAGE PatternSynonyms #-} \ +pattern Foo s <- Bar s _ where Foo s = Bar s s +{-# LANGUAGE PatternSynonyms #-} \ +x = 42 -- +{-# LANGUAGE MultiWayIf #-} \ +x = if | b1 -> v1 | b2 -> v2 | otherwise -> v3 +{-# LANGUAGE MultiWayIf #-} \ +x = if b1 then v1 else if b2 then v2 else v3 -- +static = 42 +{-# LANGUAGE NamedFieldPuns #-} \ +foo Foo{x} = x +{-# LANGUAGE NamedFieldPuns #-} \ +foo = Foo{x} +{-# LANGUAGE NamedFieldPuns #-} \ +foo = bar{x} +{-# LANGUAGE NamedFieldPuns #-} -- +{-# LANGUAGE StaticPointers #-} \ +static = 42 -- -} module Hint.Extensions(extensionsHint) where -import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule,extensionImpliedBy,extensionImplies) -import Language.Haskell.Exts.Extension +import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule) +import Extension import Data.Generics.Uniplate.Operations import Control.Monad.Extra +import Data.Char import Data.List.Extra -import Data.Ratio import Data.Data import Refact.Types import qualified Data.Set as Set import qualified Data.Map as Map import SrcLoc -import HsSyn +import GHC.Hs import BasicTypes import Class import RdrName import OccName import ForeignCall + import GHC.Util +import GHC.LanguageExtensions.Type + +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr +import Language.Haskell.GhclibParserEx.GHC.Hs.Types +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls +import Language.Haskell.GhclibParserEx.GHC.Driver.Session extensionsHint :: ModuHint extensionsHint _ x = @@ -169,21 +234,37 @@ sl (comment (mkLangExts sl exts)) (Just newPragma) - ( [RequiresExtension $ prettyExtension gone | x <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++ - [ Note $ "Extension " ++ prettyExtension x ++ " is " ++ reason x + ( [RequiresExtension (show gone) | x <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++ + [ Note $ "Extension " ++ show x ++ " is " ++ reason x | x <- explainedRemovals]) [ModifyComment (toSS' (mkLangExts sl exts)) newPragma] - | (LL sl _, exts) <- langExts $ pragmas (ghcAnnotations x) - , let before = map parseExtension exts + | (L sl _, exts) <- langExts $ pragmas (ghcAnnotations x) + , let before = map lookupExt (filterEnabled exts) , let after = filter (`Set.member` keep) before , before /= after , let explainedRemovals | null after && not (any (`Map.member` implied) before) = [] | otherwise = before \\ after , let newPragma = - if null after then "" else comment (mkLangExts sl $ map prettyExtension after) + if null after then "" else comment (mkLangExts sl $ map show after) ] where + filterEnabled :: [String] -> [String] + filterEnabled = filter (not . isPrefixOf "No") + + lookupExt :: String -> Extension + lookupExt s = case readExtension s of + Just ext -> ext + Nothing -> + -- Validity checking of extensions happens when the parse + -- tree is constructed (via 'getOptions' called from + -- 'parsePragmasIntoDynFlags'). If an invalid extension is + -- encountered, it results in a parse error (see + -- tests/ignore-parse-error3.hs in + -- 'tests/parse-error.test'). Thus we are assured that the + -- argument 's' must be in 'xFlags' and this case impossible. + error ("IMPOSSIBLE: Unrecognized language extension '" ++ s ++ "'") + usedTH :: Bool usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x) -- If TH or QuasiQuotes is on, can use all other extensions @@ -191,9 +272,10 @@ -- All the extensions defined to be used. extensions :: Set.Set Extension - extensions = Set.fromList [ parseExtension e - | let exts = concatMap snd $ langExts (pragmas (ghcAnnotations x)) + extensions = Set.fromList $ [ lookupExt e + | let exts = concatMap (filterEnabled . snd) $ langExts (pragmas (ghcAnnotations x)) , e <- exts ] + -- Those extensions we detect to be useful. useful :: Set.Set Extension useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions @@ -203,25 +285,27 @@ implied = Map.fromList [ (e, a) | e <- Set.toList useful - , a:_ <- [filter (`Set.member` useful) $ extensionImpliedBy e]] + , a:_ <- [filter (`Set.member` useful) $ extensionImpliedEnabledBy e] + ] -- Those we should keep. keep :: Set.Set Extension keep = useful `Set.difference` Map.keysSet implied -- The meaning of (a,b) is a used to imply b, but has gone, so -- suggest enabling b. + disappear :: Map.Map Extension [Extension] disappear = Map.fromListWith (++) $ nubOrdOn snd -- Only keep one instance for each of a. [ (e, [a]) | e <- Set.toList $ extensions `Set.difference` keep - , a <- extensionImplies e + , a <- fst $ extensionImplies e , a `Set.notMember` useful , usedTH || usedExt a (ghcModule x) ] reason :: Extension -> String reason x = case Map.lookup x implied of - Just a -> "implied by " ++ prettyExtension a + Just a -> "implied by " ++ show a Nothing -> "not used" deriveHaskell = ["Eq","Ord","Enum","Ix","Bounded","Read","Show"] @@ -238,13 +322,14 @@ deriveStock = deriveHaskell ++ deriveGenerics ++ deriveCategory usedExt :: Extension -> Located (HsModule GhcPs) -> Bool -usedExt (EnableExtension x) = used x -usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac -usedExt (UnknownExtension "DeriveLift") = hasDerive ["Lift"] -usedExt (UnknownExtension "DeriveAnyClass") = not . null . derivesAnyclass . derives -usedExt _ = const True +usedExt NumDecimals = hasS isWholeFrac + -- Only whole number fractions are permitted by NumDecimals + -- extension. Anything not-whole raises an error. +usedExt DeriveLift = hasDerive ["Lift"] +usedExt DeriveAnyClass = not . null . derivesAnyclass . derives +usedExt x = used x -used :: KnownExtension -> Located (HsModule GhcPs) -> Bool +used :: Extension -> Located (HsModule GhcPs) -> Bool used RecursiveDo = hasS isMDo ||^ hasS isRecStmt used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep (Located RdrName)) @@ -258,15 +343,11 @@ used EmptyCase = hasS f where f :: HsExpr GhcPs -> Bool - f (HsCase _ _ (MG _ (LL _ []) _)) = True - f (HsLamCase _ (MG _ (LL _ []) _)) = True + f (HsCase _ _ (MG _ (L _ []) _)) = True + f (HsLamCase _ (MG _ (L _ []) _)) = True f _ = False used KindSignatures = hasT (un :: HsKind GhcPs) -used BangPatterns = hasS isPBangPat' ||^ hasS isStrictMatch - where - isStrictMatch :: HsMatchContext RdrName -> Bool - isStrictMatch FunRhs{mc_strictness=SrcStrict} = True - isStrictMatch _ = False +used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl where f :: HsBracket GhcPs -> Bool @@ -278,17 +359,33 @@ where f :: GRHS GhcPs (LHsExpr GhcPs) -> Bool f (GRHS _ xs _) = g xs - f _ = False -- new ctor + f _ = False -- Extension constructor g :: [GuardLStmt GhcPs] -> Bool g [] = False - g [LL _ BodyStmt{}] = False + g [L _ BodyStmt{}] = False g _ = True -used StandaloneDeriving = hasS isDerivD' -used PatternSignatures = hasS isPatTypeSig' -used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot' -used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun -used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun -used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed) ||^ hasS isDeriving +used StandaloneDeriving = hasS isDerivD +used TypeOperators = hasS tyOpInSig ||^ hasS tyOpInDecl + where + tyOpInSig :: HsType GhcPs -> Bool + tyOpInSig = \case + HsOpTy{} -> True; _ -> False + + tyOpInDecl :: HsDecl GhcPs -> Bool + tyOpInDecl = \case + (TyClD _ (FamDecl _ FamilyDecl{fdLName})) -> isOp fdLName + (TyClD _ SynDecl{tcdLName}) -> isOp tcdLName + (TyClD _ DataDecl{tcdLName}) -> isOp tcdLName + (TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs]) + _ -> False + + isOp :: LIdP GhcPs -> Bool + isOp name = case occNameString (rdrNameOcc (unLoc name)) of + (c:_) -> not $ isAlpha c || c == '_' + _ -> False +used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot +used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate +used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving where -- detect if there are deriving declarations or data ... deriving stuff -- by looking for the deriving strategy both contain (even if its Nothing) @@ -300,37 +397,41 @@ f :: ImportDecl GhcPs -> Bool f ImportDecl{ideclPkgQual=Just _} = True f _ = False -used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote' -used ViewPatterns = hasS isPViewPat' -used DefaultSignatures = hasS isClsDefSig' +used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote +used ViewPatterns = hasS isPViewPat +used InstanceSigs = hasS f + where + f :: HsDecl GhcPs -> Bool + f (InstD _ decl) = hasT (un :: Sig GhcPs) decl + f _ = False +used DefaultSignatures = hasS isClsDefSig used DeriveDataTypeable = hasDerive ["Data","Typeable"] used DeriveFunctor = hasDerive ["Functor"] used DeriveFoldable = hasDerive ["Foldable"] used DeriveTraversable = hasDerive ["Traversable","Foldable","Functor"] used DeriveGeneric = hasDerive ["Generic","Generic1"] used GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives +used MultiWayIf = hasS isMultiIf used LambdaCase = hasS isLCase used TupleSections = hasS isTupleSection used OverloadedStrings = hasS isString -used Arrows = hasS f - where - f :: HsExpr GhcPs -> Bool - f HsProc{} = True - f HsArrApp{} = True - f _ = False -used TransformListComp = hasS f - where - f :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool - f TransStmt{} = True - f _ = False +used Arrows = hasS isProc +used TransformListComp = hasS isTransStmt used MagicHash = hasS f ||^ hasS isPrimLiteral where f :: RdrName -> Bool f s = "#" `isSuffixOf` (occNameString . rdrNameOcc) s --- For forwards compatibility, if things ever get added to the --- extension enumeration. -used x = usedExt $ UnknownExtension $ show x +used PatternSynonyms = hasS isPatSynBind ||^ hasS isPatSynIE + where + isPatSynBind :: HsBind GhcPs -> Bool + isPatSynBind PatSynBind{} = True + isPatSynBind _ = False + isPatSynIE :: IEWrappedName RdrName -> Bool + isPatSynIE IEPattern{} = True + isPatSynIE _ = False +used _= const True + hasDerive :: [String] -> Located (HsModule GhcPs) -> Bool hasDerive want = any (`elem` want) . derivesStock' . derives @@ -357,38 +458,35 @@ addDerives nt _ xs = mempty {derivesStock' = stock ,derivesAnyclass = other - ,derivesNewtype' = if maybe True isNewType' nt then filter (`notElem` noDeriveNewtype) xs else []} + ,derivesNewtype' = if maybe True isNewType nt then filter (`notElem` noDeriveNewtype) xs else []} where (stock, other) = partition (`elem` deriveStock) xs derives :: Located (HsModule GhcPs) -> Derives -derives (LL _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m) +derives (L _ m) = mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m) where idecl :: Located (DataFamInstDecl GhcPs) -> Derives - idecl (LL _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(LL _ ds)}}))) = g dn ds + idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds idecl _ = mempty decl :: LHsDecl GhcPs -> Derives - decl (LL _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(LL _ ds)}))) = g dn ds -- Data declaration. - decl (LL _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration. + decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration. + decl (L _ (DerivD _ (DerivDecl _ (HsWC _ sig) strategy _))) = addDerives Nothing (fmap unLoc strategy) [derivedToStr sig] -- A deriving declaration. decl _ = mempty g :: NewOrData -> [LHsDerivingClause GhcPs] -> Derives - g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | LL _ (HsDerivingClause _ strategy (LL _ tys)) <- ds] + g dn ds = mconcat [addDerives (Just dn) (fmap unLoc strategy) $ map derivedToStr tys | L _ (HsDerivingClause _ strategy (L _ tys)) <- ds] derivedToStr :: LHsSigType GhcPs -> String derivedToStr (HsIB _ t) = ih t where ih :: LHsType GhcPs -> String - ih (LL _ (HsQualTy _ _ a)) = ih a - ih (LL _ (HsParTy _ a)) = ih a - ih (LL _ (HsAppTy _ a _)) = ih a - ih (LL _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual' a - ih (LL _ a) = unsafePrettyPrint a -- I don't anticipate this case is called. - ih _ = "" -- {-# COMPLETE LL #-} + ih (L _ (HsQualTy _ _ a)) = ih a + ih (L _ (HsParTy _ a)) = ih a + ih (L _ (HsAppTy _ a _)) = ih a + ih (L _ (HsTyVar _ _ a)) = unsafePrettyPrint $ unqual' a + ih (L _ a) = unsafePrettyPrint a -- I don't anticipate this case is called. derivedToStr _ = "" -- new ctor -derives _ = mempty -- {-# COMPLETE LL #-} - un = undefined hasT t x = not $ null (universeBi x `asTypeOf` [t]) @@ -396,12 +494,3 @@ hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi - -has f = any f . universeBi - --- Only whole number fractions are permitted by NumDecimals extension. --- Anything not-whole raises an error. -isWholeFrac :: HsExpr GhcPs -> Bool -isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1 -isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1 -isWholeFrac _ = False diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-} +{-# LANGUAGE PatternGuards, RecordWildCards #-} {- Reduce the number of import declarations. Two import declarations can be combined if: @@ -28,11 +28,11 @@ import qualified A; import A import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar) -import List -- import Data.List -import qualified List -- import qualified Data.List as List -import Char(foo) -- import Data.Char(foo) +import List -- import Data.List @NoRefactor: apply-refact bug +import qualified List -- import qualified Data.List as List @NoRefactor +import Char(foo) -- import Data.Char(foo) @NoRefactor import IO(foo) -import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) +import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) @NoRefactor -} @@ -53,7 +53,7 @@ import BasicTypes import RdrName import Module -import HsSyn +import GHC.Hs import SrcLoc import GHC.Util @@ -97,7 +97,7 @@ combine :: LImportDecl GhcPs -> LImportDecl GhcPs -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan]) -combine x@(LL _ x') y@(LL _ y') +combine x@(L _ x') y@(L _ y') -- Both (un/)qualified, common 'as', same names : Delete the second. | qual, as, specs = Just (x, [Delete Import (toSS' y)]) -- Both (un/)qualified, common 'as', different names : Merge the @@ -115,7 +115,7 @@ in Just (newImp, [Delete Import (toSS' toDelete)]) -- Both unqualified, same names, one (and only one) has an 'as' -- clause : Delete the one without an 'as'. - | not (ideclQualified x'), qual, specs, length ass == 1 = + | ideclQualified x' == NotQualified, qual, specs, length ass == 1 = let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x) in Just (newImp, [Delete Import (toSS' toDelete)]) -- No hints. @@ -131,17 +131,16 @@ 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@(LL loc i@ImportDecl {..}) +stripRedundantAlias x@(L loc i@ImportDecl {..}) -- Suggest 'import M as M' be just 'import M'. | 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@(LL loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing}) +preferHierarchicalImports x@(L loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing}) -- Suggest 'import IO' be rewritten 'import System.IO, import -- System.IO.Error, import Control.Exception(bracket, bracket_)'. | n == mkModuleName "IO" && isNothing (ideclHiding i) = @@ -162,11 +161,11 @@ 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 noExtField (noLoc (IEName (noLoc (mkVarUnqual (fsLit n))))) -- Rewrite 'import qualified X' as 'import qualified X as X'. desugarQual :: ImportDecl GhcPs -> ImportDecl GhcPs desugarQual i - | ideclQualified i && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)} + | ideclQualified i /= NotQualified && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)} | otherwise = i preferHierarchicalImports _ = [] diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -22,37 +22,39 @@ f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a +f (Just a) = \a -> a + a -- f (Just _) a = a + a @NoRefactor f a = \x -> x + x where _ = test f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x -fun x y z = f x y z -- fun = f -fun x y z = f x x y z -- fun x = f x x -fun x y z = f g z -- fun x y = f g -fun mr = y mr -fun x = f . g $ x -- fun = f . g +fun x y z = f x y z -- fun = f @NoRefactor: refactoring for eta reduce is not implemented +fun x y z = f x x y z -- fun x = f x x @NoRefactor +fun x y z = f g z -- fun x y = f g @NoRefactor +fun x = f . g $ x -- fun = f . g @NoRefactor f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda -f = foo ((*) x) -- (x *) +f = foo ((*) x) -- (x *) @NoRefactor f = (*) x -f = foo (flip op x) -- (`op` x) -f = foo (flip op x) -- @Message Use section +f = foo (flip op x) -- (`op` x) @NoRefactor +f = foo (flip op x) -- @Message Use section @NoRefactor foo x = bar (\ d -> search d table) -- (`search` table) foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix` f = flip op x -f = foo (flip (*) x) -- (* x) +f = foo (flip (*) x) -- (* x) @NoRefactor f = foo (flip (-) x) f = foo (\x y -> fun x y) -- @Warning fun +f = foo (\x y z -> fun x y z) -- @Warning fun +f = foo (\z -> f x $ z) -- f x f = foo (\x y -> x + y) -- (+) f = foo (\x -> x * y) -- @Suggestion (* y) f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(foo -> x) -> \y -> x x y y) -f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x +f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x @NoRefactor f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i) -f = bar (flip Foo.bar x) -- (`Foo.bar` x) +f = bar (flip Foo.bar x) -- (`Foo.bar` x) @NoRefactor f = a b (\x -> c x d) -- (`c` d) yes = \x -> a x where -- a yes = \x y -> op y x where -- flip op @@ -65,18 +67,24 @@ foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m] -foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) +foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) @NoRefactor foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f -baz = bar (\x -> (x +)) -- (+) -foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z -yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b +foo = bar (\x -> shakeRoot "src" x) +baz = bar (\x -> (x +)) -- (+) @NoRefactor +xs `withArgsFrom` args = f args +foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z @NoRefactor +yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b @NoRefactor +yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file @NoRefactor no = blah (\ x -> case x of A -> a x; B -> b x) -yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) +yes = blah (\ x -> (y, x)) -- (y,) @NoRefactor +yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) @NoRefactor +yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @NoRefactor +yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST $ action x) -yes = map (\f -> dataDir f) dataFiles -- (dataDir ) +yes = map (\f -> dataDir f) dataFiles -- (dataDir ) @NoRefactor {-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a]) {-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name {-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name) @@ -86,96 +94,178 @@ module Hint.Lambda(lambdaHint) where -import Hint.Util -import Hint.Type +import Hint.Type (DeclHint', Idea, Note(RequiresExtension), suggest', warn', toSS', suggestN', ideaNote) import Util import Data.List.Extra -import Data.Maybe import qualified Data.Set as Set import Refact.Types hiding (RType(Match)) +import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi) +import BasicTypes +import GHC.Util.Brackets (isAtom') +import GHC.Util.FreeVars (free', allVars', freeVars', pvars', vars', varss') +import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR', lambda) +import GHC.Util.Outputable +import GHC.Util.RdrName (rdrNameStr') +import GHC.Util.View +import GHC.Hs +import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar) +import OccName +import RdrName +import SrcLoc -lambdaHint :: DeclHint -lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x) +lambdaHint :: DeclHint' +lambdaHint _ _ x + = concatMap (uncurry lambdaExp) (universeParentBi x) + ++ concatMap lambdaDecl (universe x) +lambdaDecl :: LHsDecl GhcPs -> [Idea] +lambdaDecl + o@(L _ (ValD _ + origBind@FunBind {fun_id = L loc1 _, fun_matches = + MG {mg_alts = + L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}})) + | L _ (EmptyLocalBinds noExtField) <- bind + , isLambda $ fromParen' origBody + , null (universeBi pats :: [HsExpr GhcPs]) + = [warn' "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS' o) s1 t1]] + | length pats2 < length pats, pvars' (drop (length pats2) pats) `disjoint` varss' bind + = [warn' "Eta reduce" (reform pats origBody) (reform pats2 bod2) + [ -- Disabled, see apply-refact #3 + -- Replace Decl (toSS' $ reform' pats origBody) s2 t2]] + ]] + where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs + reform ps b = L loc $ ValD noExtField $ + origBind + {fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated} -lambdaDecl :: Decl_ -> [Idea] -lambdaDecl (toFunBind -> o@(FunBind loc1 [Match _ name pats (UnGuardedRhs loc2 bod) bind])) - | isNothing bind, isLambda $ fromParen bod, null (universeBi pats :: [Exp_]) = - [warn "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]] - | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind - = [warn "Eta reduce" (reform pats bod) (reform pats2 bod2) - [ -- Disabled, see apply-refact #3 - -- Replace Decl (toSS $ reform pats bod) s2 t2]] - ]] - where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing] - loc = setSpanInfoEnd loc1 $ srcSpanEnd $ srcInfoSpan loc2 - gen ps = uncurry reform . fromLambda . Lambda an ps - (finalpats, body) = fromLambda . Lambda an pats $ bod - (pats2, bod2) = etaReduce pats bod - template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (toNamed "body") - munge :: Char -> Pat_ -> Pat_ - munge ident p@(PWildCard _) = p - munge ident p = PVar (ann p) (Ident (ann p) [ident]) - subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps) - s1 = subts finalpats body - --s2 = subts pats2 bod2 - t1 = template finalpats body - --t2 = template pats2 bod2 + loc = combineSrcSpans loc1 loc2 -lambdaDecl _ = [] + gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs + gen ps = uncurry reform . fromLambda . lambda ps -setSpanInfoEnd ssi (line, col) = ssi{srcInfoSpan = (srcInfoSpan ssi){srcSpanEndLine=line, srcSpanEndColumn=col}} + (finalpats, body) = fromLambda . lambda pats $ origBody + (pats2, bod2) = etaReduce pats origBody + template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody + subts fps b = ("body", toSS' b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' fps) + s1 = subts finalpats body + --s2 = subts pats2 bod2 + t1 = template finalpats + --t2 = template pats2 bod2 +lambdaDecl _ = [] -etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_) -etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y)))) - | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x +etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) +etaReduce (unsnoc -> Just (ps, view' -> PVar_' p)) (L _ (HsApp _ x (view' -> Var_' y))) + | p == y + , y `notElem` vars' x , not $ any isQuasiQuote $ universe x - = etaReduce (init ps) x -etaReduce ps (InfixApp a x (isDol -> True) y) = etaReduce ps (App a x y) -etaReduce ps x = (ps,x) - + = etaReduce ps x +etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) +etaReduce ps x = (ps, x) --Section refactoring is not currently implemented. -lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea] -lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, not $ isTypeApp y, allowLeftSection x = - [suggestN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]] +lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] +lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ (L _ (rdrNameOcc -> f)))) y)))) + | isSymOcc f -- is this an operator? + , isAtom' y + , allowLeftSection $ occNameString f + , not $ isTypeApp y = + [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper] + +lambdaExp _ o@(L _ (HsPar _ (view' -> App2' (view' -> Var_' "flip") origf@(view' -> Var_' f) y))) + | allowRightSection f + = [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y] +lambdaExp p o@(L _ HsLam{}) + | not $ any isOpApp p + , (res, refact) <- niceLambdaR' [] o + , not $ isLambda res + , not $ any isQuasiQuote $ universe res + , not $ "runST" `Set.member` Set.map occNameString (freeVars' o) + , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "") + = [(if isVar res then warn' else suggest') name o res (refact $ toSS' o)] where - exp op rhs = LeftSection an op (toNamed rhs) --- template = prettyPrint (exp (toNamed "a") "*") --- subts = [("a", toSS y), ("*", toSS v)] -lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x = - [suggestN "Use section" o $ RightSection an (QVarOp an x) y] -lambdaExp p o@Lambda{} - | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o - , not $ isLambda res, not $ any isQuasiQuote $ universe res, not $ "runST" `Set.member` freeVars o - , let name = "Avoid lambda" ++ (if countInfixNames res > countInfixNames o then " using `infix`" else "") = - [(if isVar res || isCon res then warn else suggest) name o res (refact $ toSS o)] - where countInfixNames x = length [() | RightSection _ (QVarOp _ (UnQual _ (Ident _ _))) _ <- universe x] -lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p = - [suggest "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]] + countRightSections :: LHsExpr GhcPs -> Int + countRightSections x = length [() | L _ (SectionR _ (view' -> Var_' _) _) <- universe x] +lambdaExp p o@(SimpleLambda origPats origBody) + | isLambda (fromParen' origBody) + , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that? + , maybe True (not . isLambda) p = + [suggest' "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS' o) subts template]] where (pats, body) = fromLambda o - template = prettyPrint $ Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body") - munge :: Char -> Pat_ -> Pat_ - munge ident p@(PWildCard _) = p - munge ident p = PVar (ann p) (Ident (ann p) [ident]) - subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats) -lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts)) - | u == v, u `notElem` vars alts = case alts of - [Alt _ pat (UnGuardedRhs _ bod) Nothing] -> [suggestN "Use lambda" o $ Lambda an [pat] bod] - _ -> [(suggestN "Use lambda-case" o $ LCase an alts){ideaNote=[RequiresExtension "LambdaCase"]}] -lambdaExp p o@(Lambda _ [view -> PVar_ u] (Tuple _ boxed xs)) - | ([yes],no) <- partition (~= u) xs, u `notElem` concatMap vars no - = [(suggestN "Use tuple-section" o $ TupleSection an boxed [if x ~= u then Nothing else Just x | x <- xs]) - {ideaNote=[RequiresExtension "TupleSections"]}] + + template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody + + subts = ("body", toSS' body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' pats) + +-- match a lambda with a variable pattern, with no guards and no where clauses +lambdaExp _ o@(SimpleLambda [view' -> PVar_' x] (L _ expr)) = + case expr of + -- suggest TupleSections instead of lambdas + ExplicitTuple _ args boxity + -- is there exactly one argument that is exactly x? + | ([_x], ys) <- partition ((==Just x) . tupArgVar) args + -- the other arguments must not have a nested x somewhere in them + , Set.notMember x $ Set.map occNameString $ freeVars' ys + -> [(suggestN' "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity) + {ideaNote = [RequiresExtension "TupleSections"]}] + + -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@ + HsCase _ (view' -> Var_' x') matchGroup + -- is the case being done on the variable from our original lambda? + | x == x' + -- x must not be used in some other way inside the matches + , Set.notMember x $ Set.map occNameString $ free' $ allVars' matchGroup + -> case matchGroup of + -- is there a single match? - suggest match inside the lambda + -- + -- we need to + -- * add brackets to the match, because matches in lambdas require them + -- * mark match as being in a lambda context so that it's printed properly + oldMG@(MG _ (L _ [L _ oldmatch]) _) -> + [suggestN' "Use lambda" o $ noLoc $ HsLam noExtField oldMG + { mg_alts = noLoc + [noLoc oldmatch + { m_pats = map mkParPat $ m_pats oldmatch + , m_ctxt = LambdaExpr + } + ] } + ] + + -- otherwise we should use @LambdaCase@ + MG _ (L _ xs) _ -> + [(suggestN' "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup) + {ideaNote=[RequiresExtension "LambdaCase"]}] + _ -> [] + _ -> [] + where + -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument + -- to a missing argument, so that we get the proper section. + removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs + removeX arg@(L _ (Present _ (view' -> Var_' x'))) + | x == x' = noLoc $ Missing noExtField + removeX y = y + -- | Extract the name of an argument of a tuple if it's present and a variable. + tupArgVar :: LHsTupArg GhcPs -> Maybe String + tupArgVar (L _ (Present _ (view' -> Var_' x))) = Just x + tupArgVar _ = Nothing + lambdaExp _ _ = [] +varBody :: LHsExpr GhcPs +varBody = strToVar "body" --- replace any repeated pattern variable with _ -fromLambda :: Exp_ -> ([Pat_], Exp_) -fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x) - where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an +-- | Squash lambdas and replace any repeated pattern variable with @_@ +fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) +fromLambda (SimpleLambda ps1 (fromLambda . fromParen' -> (ps2,x))) = (transformBi (f $ pvars' ps2) ps1 ++ ps2, x) + where f :: [String] -> Pat GhcPs -> Pat GhcPs + f bad (VarPat _ (rdrNameStr' -> x)) + | x `elem` bad = WildPat noExtField f bad x = x fromLambda x = ([], x) + +-- | Replaces all non-wildcard patterns with a variable pattern with the given identifier. +munge :: Char -> LPat GhcPs -> LPat GhcPs +munge ident p@(L _ (WildPat _)) = p +munge ident (L ploc p) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident])) diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -13,7 +13,7 @@ no = "x" ++ xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys -yes = [if a then b else c] ++ xs -- (if a then b else c) : xs +yes = [if a then b else c] ++ xs -- (if a then b else c) : xs @NoRefactor: hlint bug, missing brackets in refactoring template yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]] yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs data Yes = Yes (Maybe [Char]) -- Maybe String @@ -43,12 +43,12 @@ import Data.Maybe import Prelude -import Hint.Type(DeclHint',Idea,suggest',toSS') +import Hint.Type(DeclHint',Idea,suggest',toRefactSrcSpan',toSS') import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R -import HsSyn +import GHC.Hs import SrcLoc import BasicTypes import RdrName @@ -58,7 +58,9 @@ import TysWiredIn import GHC.Util +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr +import Language.Haskell.GhclibParserEx.GHC.Hs.Types import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances listHint :: DeclHint' @@ -75,21 +77,21 @@ -- structure of 'listComp'. listComp :: LHsExpr GhcPs -> [Idea] -listComp o@(LL _ (HsDo _ ListComp (L _ stmts))) = +listComp o@(L _ (HsDo _ ListComp (L _ stmts))) = listCompCheckGuards o ListComp stmts -listComp o@(LL _ (HsDo _ MonadComp (L _ stmts))) = +listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) = listCompCheckGuards o MonadComp stmts -listComp o@(view' -> App2' mp f (LL _ (HsDo _ ListComp (L _ stmts)))) = +listComp o@(view' -> App2' mp f (L _ (HsDo _ ListComp (L _ stmts)))) = listCompCheckMap o mp f ListComp stmts -listComp o@(view' -> App2' mp f (LL _ (HsDo _ MonadComp (L _ stmts)))) = +listComp o@(view' -> App2' mp f (L _ (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. + e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last. xs = reverse (tail revs) in list_comp_aux e xs where @@ -100,12 +102,12 @@ | otherwise = [] where ys = moveGuardsForward xs - 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]) + o' = noLoc $ ExplicitList noExtField Nothing [] + o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e])) + o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e]) cons = mapMaybe qualCon xs qualCon :: ExprLStmt GhcPs -> Maybe String - qualCon (L _ (BodyStmt _ (LL _ (HsVar _ (L _ x))) _ _)) = Just (occNameString . rdrNameOcc $ x) + qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameString . rdrNameOcc $ x) qualCon _ = Nothing listCompCheckMap :: @@ -114,9 +116,9 @@ [suggest' "Move map inside list comprehension" o o2 (suggestExpr o o2)] where 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]) + L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last. + last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren' f) (paren' body)) b s + o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last]) listCompCheckMap _ _ _ _ _ = [] suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan] @@ -127,16 +129,24 @@ 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) + span (if any hasPFieldsDotDot (universeBi x) + || any isPFieldWildcard (universeBi x) then const False - else \x -> pvars' p `disjoint` vars_ x) guards + else \x -> + let pvars = pvars' p in + -- See this code from 'RdrHsSyn.hs' (8.10.1): + -- plus_RDR, pun_RDR :: RdrName + -- plus_RDR = mkUnqual varName (fsLit "+") -- Hack + -- pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + -- Todo (SF, 2020-03-28): Try to make this better somehow. + pvars `disjoint` vars_ x && "pun-right-hand-side" `notElem` pvars + ) 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 -- Fake something that works - vars_ x = [unsafePrettyPrint a | HsVar _ (LL _ a) <- universeBi x :: [HsExpr GhcPs]] + vars_ x = [unsafePrettyPrint a | HsVar _ (L _ a) <- universeBi x :: [HsExpr GhcPs]] listExp :: Bool -> LHsExpr GhcPs -> [Idea] listExp b (fromParen' -> x) = @@ -147,7 +157,7 @@ , Just (x2, subts, temp) <- [f b x] , let r = Replace Expr (toSS' x) subts temp ] -listPat :: Pat GhcPs -> [Idea] +listPat :: LPat 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 @@ -158,54 +168,54 @@ isAppend _ = False checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))] -checks = let (*) = (,) in drop 1 -- see #174 +checks = let (*) = (,) in drop1 -- see #174 [ "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 +pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))] +pchecks = let (*) = (,) in drop1 -- see #174 [ "Use string literal pattern" * usePString , "Use list literal pattern" * usePList ] -usePString :: 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))) +usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String) +usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs = + let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) in Just (literal, [], unsafePrettyPrint literal) usePString _ = Nothing -usePList :: Pat GhcPs -> Maybe (Pat GhcPs, [(String, R.SrcSpan)], String) +usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList = fmap ( (\(e, s) -> - (noLoc (ListPat noExt e) - , map (fmap toSS') s - , unsafePrettyPrint (noLoc $ ListPat noExt (map snd s) :: Pat GhcPs)) + (noLoc (ListPat noExtField e) + , map (fmap toRefactSrcSpan' . fst) s + , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs)) ) . unzip ) . f True ['a'..'z'] where - f first _ x | patToStr' x == "[]" = if first then Nothing else Just [] + 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 GhcPs -> (String, Pat GhcPs) - g c p = ([c], VarPat noExt (noLoc $ mkVarUnqual (fsLit [c]))) + g :: Char -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs) + g c (getLoc -> loc) = (([c], loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit [c]))) 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)))) +useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs = + let literal = noLoc (HsLit noExtField (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) -> - (noLoc (ExplicitList noExt Nothing e) + (noLoc (ExplicitList noExtField Nothing e) , map (fmap toSS') s - , unsafePrettyPrint (noLoc $ ExplicitList noExt Nothing (map snd s) :: LHsExpr GhcPs)) + , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs)) ) . unzip ) @@ -217,7 +227,7 @@ f first _ _ = Nothing g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs) - g c p = ([c], strToVar [c]) + g c p = ([c], L (getLoc p) (unLoc $ strToVar [c])) useCons :: View' a App2' => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useCons False (view' -> App2' op x y) | varToStr op == "++" @@ -230,25 +240,25 @@ where f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs) - f (LL _ (ExplicitList _ _ [x]))= + f (L _ (ExplicitList _ _ [x]))= Just (x, \v -> if isApp x then v else paren' v) f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - gen x = noLoc . OpApp noExt x (noLoc (HsVar noExt (noLoc consDataCon_RDR))) + gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField (noLoc consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar = - noLoc $ HsListTy noExt - (noLoc (HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "Char"))))) + noLoc $ HsListTy noExtField + (noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString = - noLoc $ HsTyVar noExt NotPromoted (noLoc (mkVarUnqual (fsLit "String"))) + noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String"))) stringType :: LHsDecl GhcPs -> [Idea] -stringType (LL _ x) = case x of +stringType (L _ x) = case x of InstD _ ClsInstD{ cid_inst= ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} -> @@ -258,8 +268,7 @@ f x = concatMap g $ childrenBi x g :: LHsType GhcPs -> [Idea] - g e@(fromTyParen' -> x) = [suggest' "Use String" x (transform f x) + g e@(fromTyParen -> x) = [suggest' "Use String" x (transform f x) rs | not . null $ rs] where f x = if astEq x typeListChar then typeString else x rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar] -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 @@ -41,18 +41,19 @@ import Refact.Types hiding (RType(Match)) import SrcLoc -import HsExtension -import HsPat -import HsTypes +import GHC.Hs.Extension +import GHC.Hs.Pat +import GHC.Hs.Types import TysWiredIn import RdrName -import HsBinds -import HsExpr -import HsDecls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.Decls import OccName import BasicTypes import GHC.Util +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances @@ -67,7 +68,7 @@ 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)] + pure $ idea' severity ("Use " ++ use) o y [Replace Decl (toSS' o) [] (unsafePrettyPrint y)] recursiveStr :: String recursiveStr = "_recursive_" @@ -99,7 +100,7 @@ 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 == ":" + | [] <- vs, varToStr nil == "[]", (L _ (OpApp _ lhs c rhs)) <- cons, varToStr c == ":" , astEq (fromParen' rhs) recursive, xs `notElem` vars' lhs = Just $ (,,) "map" Hint.Type.Warning $ appsBracket' [ strToVar "map", niceLambda' [x] lhs, strToVar xs] @@ -110,14 +111,14 @@ = 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 + | [v] <- vs, view' nil == Var_' v, (L _ (HsApp _ r lhs)) <- cons , astEq (fromParen' r) recursive , xs `notElem` vars' lhs = Just $ (,,) "foldl" Suggestion $ appsBracket' [ strToVar "foldl", niceLambda' [v,x] lhs, strToVar v, strToVar xs] -- Suggest 'foldM'? - | [v] <- vs, (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 + | [v] <- vs, (L _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view' res == Var_' v + , [L _ (BindStmt _ (view' -> PVar_' b1) e _ _), L _ (BodyStmt _ (fromParen' -> (L _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons , b1 == b2, astEq r recursive, xs `notElem` vars' e , name <- "foldM" ++ ['_' | varToStr res == "()"] = Just $ (,,) name Suggestion $ @@ -130,19 +131,19 @@ asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)] asDo (view' -> App2' bind lhs - (LL _ (HsLam _ MG { + (L _ (HsLam _ MG { mg_origin=FromSource - , mg_alts=LL _ [ - LL _ Match { m_ctxt=LambdaExpr - , m_pats=[LL _ v@VarPat{}] + , mg_alts=L _ [ + L _ Match { m_ctxt=LambdaExpr + , m_pats=[v@(L _ VarPat{})] , m_grhss=GRHSs _ - [LL _ (GRHS _ [] rhs)] - (LL _ (EmptyLocalBinds _))}]})) + [L _ (GRHS _ [] rhs)] + (L _ (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] + [ noLoc $ BindStmt noExtField v lhs noSyntaxExpr noSyntaxExpr + , noLoc $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] +asDo (L _ (HsDo _ DoExpr (L _ stmts))) = stmts +asDo x = [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] --------------------------------------------------------------------- @@ -152,43 +153,43 @@ findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs) findCase x = do -- Match a function binding with two alternatives. - (LL _ (ValD _ FunBind {fun_matches= + (L _ (ValD _ FunBind {fun_matches= MG{mg_origin=FromSource, mg_alts= - (LL _ - [ x1@(LL _ Match{..}) -- Match fields. + (L _ + [ x1@(L _ Match{..}) -- Match fields. , x2]), ..} -- Match group fields. , ..} -- Fun. bind fields. - )) <- return x + )) <- pure x Branch name1 ps1 p1 c1 b1 <- findBranch x1 Branch name2 ps2 p2 c2 b2 <- findBranch x2 guard (name1 == name2 && ps1 == ps2 && p1 == p2) - [(BNil, b1), (BCons x xs, b2)] <- return $ sortOn fst [(c1, b1), (c2, b2)] + [(BNil, b1), (BCons x xs, b2)] <- pure $ sortOn fst [(c1, b1), (c2, b2)] b2 <- transformAppsM' (delCons name1 p1 xs) b2 - (ps, b2) <- return $ eliminateArgs ps1 b2 + (ps, b2) <- pure $ 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. + let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments. + emptyLocalBinds = noLoc $ EmptyLocalBinds noExtField -- Empty where clause. + gRHS e = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs. + gRHSSs e = GRHSs noExtField [gRHS e] emptyLocalBinds -- Guarded rhs set. + match e = Match{m_ext=noExtField,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. - return (ListCase ps b1 (x, xs, b2), noLoc . ValD noExt . funBind) + pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . funBind) delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) delCons func pos var (fromApps' -> (view' -> Var_' x) : xs) | func == x = do - (pre, (view' -> Var_' v) : post) <- return $ splitAt pos xs + (pre, (view' -> Var_' v) : post) <- pure $ splitAt pos xs guard $ v == var - return $ apps' $ recursive : pre ++ post -delCons _ _ _ x = return x + pure $ apps' $ recursive : pre ++ post +delCons _ _ _ x = pure x eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons) where args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq z recursive] - elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False + elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zipFrom 0 ps] ++ repeat False remove = concat . zipWith (\b x -> [x | not b]) elim f (fromApps' -> x : xs) | astEq x recursive = apps' $ x : remove xs @@ -207,22 +208,22 @@ GRHSs {grhssGRHSs=[L l (GRHS _ [] body)] , grhssLocalBinds=L _ (EmptyLocalBinds _) } - } <- return x + } <- pure x (a, b, c) <- findPat ps - return $ Branch (occNameString $rdrNameOcc name) a b c $ simplifyExp' body + pure $ Branch (occNameString $rdrNameOcc name) a b c $ simplifyExp' body findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList) findPat ps = do ps <- mapM readPat ps - [i] <- return $ findIndices isRight ps + [i] <- pure $ findIndices isRight ps let (left, [right]) = partitionEithers ps - return (left, i, right) + pure (left, i, right) -readPat :: Pat GhcPs -> Maybe (Either String BList) +readPat :: LPat 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)))))) +readPat (L _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view' -> PVar_' x) (view' -> PVar_' xs)))))) | n == consDataCon_RDR = Just $ Right $ BCons x xs -readPat (LL _ (ConPatIn (L _ n) (PrefixCon []))) +readPat (L _ (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 @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} -{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts #-} {- The matching does a fairly simple unification between the two terms, treating @@ -8,7 +8,6 @@ both ($) and (.) functions on the right. TRANSFORM PATTERNS -_eval_ - perform deep evaluation, must be used at the top of a RHS _noParen_ - don't bracket this particular item SIDE CONDITIONS @@ -53,7 +52,7 @@ import Data.Generics.Uniplate.Operations import Bag -import HsSyn +import GHC.Hs import SrcLoc import BasicTypes import RdrName @@ -63,50 +62,50 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea] +readMatch' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch' settings = findIdeas' (concatMap readRule' settings) readRule' :: HintRule -> [HintRule] -readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unextendInstances -> hintRuleGhcLHS) - , hintRuleGhcRHS=(stripLocs' . unextendInstances -> hintRuleGhcRHS) - , hintRuleGhcSide=((stripLocs' . unextendInstances <$>) -> hintRuleGhcSide) +readRule' m@HintRule{ hintRuleLHS=(stripLocs' . unextendInstances -> hintRuleLHS) + , hintRuleRHS=(stripLocs' . unextendInstances -> hintRuleRHS) + , hintRuleSide=((stripLocs' . unextendInstances <$>) -> hintRuleSide) } = - (:) m{ hintRuleGhcLHS=extendInstances hintRuleGhcLHS - , hintRuleGhcRHS=extendInstances hintRuleGhcRHS - , hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } $ do - (l, v1) <- dotVersion' hintRuleGhcLHS - (r, v2) <- dotVersion' hintRuleGhcRHS + (:) m{ hintRuleLHS=extendInstances hintRuleLHS + , hintRuleRHS=extendInstances hintRuleRHS + , hintRuleSide=extendInstances <$> hintRuleSide } $ do + (l, v1) <- dotVersion' hintRuleLHS + (r, v2) <- dotVersion' hintRuleRHS - guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r)) + guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleSide ++ l ++ r)) if not (null r) then - [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (dotApps' r), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } - , m{ hintRuleGhcLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleGhcRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } ] + [ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (dotApps' r), hintRuleSide=extendInstances <$> hintRuleSide } + , m{ hintRuleLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleSide=extendInstances <$> hintRuleSide } ] else if length l > 1 then - [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (strToVar "id"), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } - , m{ hintRuleGhcLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleGhcRHS=extendInstances (strToVar v1), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide}] + [ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (strToVar "id"), hintRuleSide=extendInstances <$> hintRuleSide } + , m{ hintRuleLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleRHS=extendInstances (strToVar v1), hintRuleSide=extendInstances <$> hintRuleSide}] else [] -- Find a dot version of this rule, return the sequence of app -- prefixes, and the var. dotVersion' :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)] dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)] -dotVersion' (LL _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs) -dotVersion' (LL l (OpApp _ x op y)) = +dotVersion' (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs) +dotVersion' (L l (OpApp _ x op y)) = -- In a GHC parse tree, raw sections aren't valid application terms. -- To be suitable as application terms, they must be enclosed in -- parentheses. -- If a == b then -- x is 'a', op is '==' and y is 'b' and, - let lSec = addParen' (cL l (SectionL noExt x op)) -- (a == ) - rSec = addParen' (cL l (SectionR noExt op y)) -- ( == b) + let lSec = addParen' (cL l (SectionL noExtField x op)) -- (a == ) + rSec = addParen' (cL l (SectionR noExtField op y)) -- ( == b) in (first (lSec :) <$> dotVersion' y) ++ (first (rSec :) <$> dotVersion' x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion' _ = [] --------------------------------------------------------------------- -- PERFORM THE MATCHING -findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea] +findIdeas' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList [ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes} | (name, expr) <- findDecls' decl @@ -117,30 +116,36 @@ -- | A list of root expressions, with their associated names findDecls' :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)] -findDecls' x@(LL _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) = +findDecls' x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) = [(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs] -findDecls' (LL _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite. +findDecls' (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite. findDecls' x = map (fromMaybe "" $ declName x,) $ childrenBi x -matchIdea' :: Scope' +matchIdea' :: Scope -> String -> HintRule -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)]) matchIdea' sb declName HintRule{..} parent x = do - let lhs = unextendInstances hintRuleGhcLHS - rhs = unextendInstances hintRuleGhcRHS - sa = unextendInstances hintRuleGhcScope - nm a b = scopeMatch' (sa, a) (sb, b) - u <- unifyExp' nm True lhs x + let lhs = unextendInstances hintRuleLHS + rhs = unextendInstances hintRuleRHS + sa = hintRuleScope + nm a b = scopeMatch (sa, a) (sb, b) + (u, extra) <- unifyExp nm True lhs x u <- validSubst' astEq u -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res'). - let (e, tpl) = substitute' u rhs - res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs) - guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs)) `Set.isSubsetOf` freeVars' x + let rhs' | Just fun <- extra = rebracket1' $ noLoc (HsApp noExtField fun rhs) + | otherwise = rhs + (e, tpl) = substitute' u rhs' + noParens = [varToStr $ fromParen' x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl] + + u <- pure (removeParens noParens u) + + let res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs') + guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs')) `Set.isSubsetOf` freeVars' x -- Check no unexpected new free variables. -- Check it isn't going to get broken by QuasiQuotes as per #483. If @@ -149,11 +154,14 @@ -- what free vars they make use of. guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x) - guard $ checkSide' (unextendInstances <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u + guard $ checkSide' (unextendInstances <$> hintRuleSide) $ ("original", x) : ("result", res) : fromSubst' u guard $ checkDefine' declName parent res - return (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan]) + (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst' u) then (mempty, res) else (u, tpl) + tpl <- pure $ unqualify' sa sb (performSpecial' tpl) + pure (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan]) + --------------------------------------------------------------------- -- SIDE CONDITIONS @@ -161,16 +169,16 @@ checkSide' x bind = maybe True bool x where bool :: LHsExpr GhcPs -> Bool - bool (LL _ (OpApp _ x op y)) + bool (L _ (OpApp _ x op y)) | varToStr op == "&&" = bool x && bool y | varToStr op == "||" = bool x || bool y | varToStr op == "==" = expr (fromParen1' x) `astEq` expr (fromParen1' y) - bool (LL _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y - bool (LL _ (HsPar _ x)) = bool x + bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y + bool (L _ (HsPar _ x)) = bool x - bool (LL _ (HsApp _ cond (sub -> y))) + bool (L _ (HsApp _ cond (sub -> y))) | 'i' : 's' : typ <- varToStr cond = isType typ y - bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y))) + bool (L _ (HsApp _ (L _ (HsApp _ cond (sub -> x))) (sub -> y))) | varToStr cond == "notIn" = and [extendInstances (stripLocs' x) `notElem` map (extendInstances . stripLocs') (universe y) | x <- list x, y <- list y] | varToStr cond == "notEq" = not (x `astEq` y) bool x | varToStr x == "noTypeCheck" = True @@ -178,7 +186,7 @@ bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x expr :: LHsExpr GhcPs -> LHsExpr GhcPs - expr (LL _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x + expr (L _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x expr x = x isType "Compare" x = True -- Just a hint for proof stuff @@ -189,28 +197,27 @@ 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" (LL _ (HsLit _ HsInt{})) = True - isType "LitInt" (LL _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True - isType "Var" (LL _ HsVar{}) = True - isType "App" (LL _ HsApp{}) = True - isType "InfixApp" (LL _ x@OpApp{}) = True - isType "Paren" (LL _ x@HsPar{}) = True - isType "Tuple" (LL _ ExplicitTuple{}) = True + isType "LitInt" (L _ (HsLit _ HsInt{})) = True + isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True + isType "Var" (L _ HsVar{}) = True + isType "App" (L _ HsApp{}) = True + isType "InfixApp" (L _ x@OpApp{}) = True + isType "Paren" (L _ x@HsPar{}) = True + isType "Tuple" (L _ ExplicitTuple{}) = True - isType typ (LL _ x) = + isType typ (L _ x) = let top = showConstr (toConstr x) in typ == top - isType _ _ = False -- {-# COMPLETE LL#-} asInt :: LHsExpr GhcPs -> Maybe Integer - asInt (LL _ (HsPar _ x)) = asInt x - asInt (LL _ (NegApp _ x _)) = negate <$> asInt x - asInt (LL _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x - asInt (LL _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x + asInt (L _ (HsPar _ x)) = asInt x + asInt (L _ (NegApp _ x _)) = negate <$> asInt x + asInt (L _ (HsLit _ (HsInt _ (IL _ neg x)) )) = Just $ if neg then -x else x + asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ neg x)) _))) = Just $ if neg then -x else x asInt _ = Nothing list :: LHsExpr GhcPs -> [LHsExpr GhcPs] - list (LL _ (ExplicitList _ _ xs)) = xs + list (L _ (ExplicitList _ _ xs)) = xs list x = [x] sub :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -222,8 +229,8 @@ checkDefine' :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool checkDefine' declName Nothing y = let funOrOp expr = case expr of - LL _ (HsApp _ fun _) -> funOrOp fun - LL _ (OpApp _ _ op _) -> funOrOp op + L _ (HsApp _ fun _) -> funOrOp fun + L _ (OpApp _ _ op _) -> funOrOp op other -> other in declName /= varToStr (transformBi unqual' $ funOrOp y) checkDefine' _ _ _ = True @@ -231,26 +238,24 @@ --------------------------------------------------------------------- -- TRANSFORMATION --- If it has '_eval_' do evaluation on it. +-- If it has '_noParen_', remove the brackets (if exist). performSpecial' :: LHsExpr GhcPs -> LHsExpr GhcPs -performSpecial' = transform fNoParen . fEval +performSpecial' = transform fNoParen where - fEval, fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs - fEval (LL _ (HsApp _ e x)) | varToStr e == "_eval_" = reduce' x - fEval x = x - fNoParen (LL _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x + fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs + fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x fNoParen x = x -- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded. -unqualify' :: Scope' -> Scope' -> LHsExpr GhcPs -> LHsExpr GhcPs +unqualify' :: Scope -> Scope -> LHsExpr GhcPs -> LHsExpr GhcPs unqualify' from to = transformBi f where f :: Located RdrName -> Located RdrName f x@(L _ (Unqual s)) | isUnifyVar (occNameString s) = x - f x = scopeMove' (from, x) to + f x = scopeMove (from, x) to addBracket' :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs -addBracket' (Just (i, p)) c | needBracketOld' i p c = noLoc $ HsPar noExt c +addBracket' (Just (i, p)) c | needBracketOld' i p c = noLoc $ HsPar noExtField c addBracket' _ x = x -- Type substitution e.g. 'Foo Int' for 'a' in 'Proxy a' can lead to a @@ -260,6 +265,6 @@ addBracketTy'= transformBi f where f :: LHsType GhcPs -> LHsType GhcPs - f (LL _ (HsAppTy _ t x@(LL _ HsAppTy{}))) = - noLoc (HsAppTy noExt t (noLoc (HsParTy noExt x))) + f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) = + noLoc (HsAppTy noExtField t (noLoc (HsParTy noExtField x))) f x = x diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-} +{-# LANGUAGE LambdaCase, ViewPatterns, PatternGuards, FlexibleContexts #-} {- Find and match: @@ -13,7 +13,7 @@ yes = do _ <- mapM print a; return b -- mapM_ print a no = mapM print a no = do foo ; mapM print a -yes = do (bar+foo) -- (bar+foo) +yes = do (bar+foo) -- no = do bar ; foo yes = do bar; a <- foo; return a -- do bar; foo no = do bar; a <- foo; return b @@ -27,8 +27,8 @@ yes = do x <- bar $ baz; return (f $ g x) no = do x <- bar; return (f x x) {-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook -yes = do x <- return y; foo x -- @Suggestion do let x = y; foo x -yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x +yes = do x <- return y; foo x -- @Suggestion let x = y +yes = do x <- return $ y + z; foo x -- let x = y + z no = do x <- return x; foo x no = do x <- return y; x <- return y; foo x yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return () @@ -39,31 +39,33 @@ folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait main = "wait" ~> do f a $ sleep 10 -main = print do 17 + 25 -main = print do 17 -- 17 -main = f $ do g a $ sleep 10 -- g a $ sleep 10 -main = do f a $ sleep 10 -- f a $ sleep 10 +{-# LANGUAGE BlockArguments #-}; main = print do 17 + 25 +{-# LANGUAGE BlockArguments #-}; main = print do 17 -- +main = f $ do g a $ sleep 10 -- +main = do f a $ sleep 10 -- main = do foo x; return 3; bar z -- do foo x; bar z main = void $ forM_ f xs -- forM_ f xs main = void $ forM f xs -- void $ forM_ f xs main = do _ <- forM_ f xs; bar -- forM_ f xs main = do bar; forM_ f xs; return () -- do bar; forM_ f xs main = do a; when b c; return () -- do a; when b c +bar = 1 * do {\x -> x+x} + y -} module Hint.Monad(monadHint) where -import Hint.Type(DeclHint',Idea,ideaNote,warn',toSS',suggest',Note(Note)) +import Hint.Type(DeclHint',Idea(..),ideaNote,warn',warnRemove,toSS',suggest',Note(Note)) -import HsSyn +import GHC.Hs import SrcLoc import BasicTypes import TcEvidence import RdrName import OccName import Bag +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util @@ -86,41 +88,53 @@ case x of (view' -> App2' op x1 x2) | isTag ">>" op -> f x1 (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag ">>=" op -> f x1 - (LL l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExt op) x - (LL l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExt op dol) x - (LL loc (HsDo _ _ (LL _ [LL _ (BodyStmt _ y _ _ )]))) -> [warn' "Redundant do" x y [Replace Expr (toSS' x) [("y", toSS' y)] "y"] | not $ doOperator parent y] - (LL loc (HsDo _ DoExpr (L _ xs))) -> - monadSteps (cL loc . HsDo noExt DoExpr . noLoc) xs ++ - [suggest' "Use let" x (cL loc (HsDo noExt DoExpr (noLoc y)) :: LHsExpr GhcPs) rs | Just (y, rs) <- [monadLet xs]] ++ - concat [f x | (LL _ (BodyStmt _ x _ _)) <- init xs] ++ - concat [f x | (LL _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs] + (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExtField op) x + (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExtField op dol) x + (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) -> + let doOrMDo = case ctx of MDoExpr -> "mdo"; _ -> "do" + in [ warnRemove ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS' x) [("y", toSS' y)] "y"] + | not $ doAsBrackets parent y ] + (L loc (HsDo _ DoExpr (L _ xs))) -> + monadSteps (cL loc . HsDo noExtField DoExpr . noLoc) xs ++ + [suggest' "Use let" from to [r] | (from, to, r) <- monadLet xs] ++ + concat [f x | (L _ (BodyStmt _ x _ _)) <- init xs] ++ + concat [f x | (L _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs] _ -> [] where f = monadNoResult (fromMaybe "" decl) id seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn' "Redundant void" (wrap x) x [] | returnsUnit x] + doSpan doOrMDo = \case + UnhelpfulSpan s -> UnhelpfulSpan s + RealSrcSpan s -> + let start = realSrcSpanStart s + end = mkRealSrcLoc (srcSpanFile s) (srcLocLine start) (srcLocCol start + length doOrMDo) + in RealSrcSpan (mkRealSrcSpan start end) --- Sometimes people write 'a * do a + b', to avoid brackets. --- or using BlockArguments they can write 'a do a b' -doOperator :: (Eq a, Num a) => Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool -doOperator (Just (2, LL _ (OpApp _ _ op _ ))) (LL _ OpApp {}) | not $ isDol op = True -doOperator (Just (1, LL _ HsApp{})) b | not $ isAtom' b = True -doOperator _ _ = False +-- Sometimes people write 'a * do a + b', to avoid brackets, +-- or using BlockArguments they can write 'a do a b', +-- or using indentation a * do {\b -> c} * d +-- Return True if they are using do as brackets +doAsBrackets :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool +doAsBrackets (Just (2, L _ (OpApp _ _ op _ ))) _ | isDol op = False -- not quite atomic, but close enough +doAsBrackets (Just (i, o)) x = needBracket' i o x +doAsBrackets Nothing x = False + returnsUnit :: LHsExpr GhcPs -> Bool -returnsUnit (LL _ (HsPar _ x)) = returnsUnit x -returnsUnit (LL _ (HsApp _ x _)) = returnsUnit x -returnsUnit (LL _ (OpApp _ x op _)) | isDol op = returnsUnit x -returnsUnit (LL _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs +returnsUnit (L _ (HsPar _ x)) = returnsUnit x +returnsUnit (L _ (HsApp _ x _)) = returnsUnit x +returnsUnit (L _ (OpApp _ x op _)) | isDol op = returnsUnit x +returnsUnit (L _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs returnsUnit _ = False -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] -monadNoResult inside wrap (LL l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExt) x -monadNoResult inside wrap (LL l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExt x y)) x -monadNoResult inside wrap (LL l (OpApp _ x tag@(LL _ (HsVar _ (L _ op))) y)) - | isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExt x tag y)) x - | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExt x tag) y +monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExtField) x +monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExtField x y)) x +monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y)) + | isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExtField x tag y)) x + | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExtField x tag) y monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_" @@ -133,53 +147,53 @@ -> [ExprLStmt GhcPs] -> [Idea] -- Rewrite 'do return x; $2' as 'do $2'. -monadStep wrap os@(o@(LL _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_)) +monadStep wrap os@(o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_)) = [warn' ("Redundant " ++ ret) (wrap os) (wrap xs) [Delete Stmt (toSS' o)]] -- Rewrite 'do a <- $1; return a' as 'do $1'. -monadStep wrap o@[ g@(LL _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ )) - , q@(LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ v)))) _ _))] +monadStep wrap o@[ g@(L _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ )) + , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))] | occNameString (rdrNameOcc p) == occNameString (rdrNameOcc v) - = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr]) + = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr]) [Replace Stmt (toSS' g) [("x", toSS' x)] "x", Delete Stmt (toSS' q)]] -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'. -monadStep wrap o@(g@(LL _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(LL _ (BodyStmt _ (view' -> Var_' v) _ _)):xs) +monadStep wrap o@(g@(L _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(L _ (BodyStmt _ (view' -> Var_' v) _ _)):xs) | p == v && v `notElem` varss' xs - = let app = noLoc $ HsApp noExt (strToVar "join") x - body = noLoc $ BodyStmt noExt (rebracket1' app) noSyntaxExpr noSyntaxExpr + = let app = noLoc $ HsApp noExtField (strToVar "join") x + body = noLoc $ BodyStmt noExtField (rebracket1' app) noSyntaxExpr noSyntaxExpr stmts = body : xs in [warn' "Use join" (wrap o) (wrap stmts) r] where r = [Replace Stmt (toSS' g) [("x", toSS' x)] "join x", Delete Stmt (toSS' q)] -- Redundant variable capture. Rewrite 'do _ <- ; $1' as -- 'do ; $1'. -monadStep wrap (o@(LL loc (BindStmt _ p x _ _)) : rest) - | isPWildCard' p, returnsUnit x - = let body = cL loc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs +monadStep wrap (o@(L loc (BindStmt _ p x _ _)) : rest) + | isPWildcard p, returnsUnit x + = let body = cL loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs in [warn' "Redundant variable capture" o body []] -- Redundant unit return : 'do ; return ()'. monadStep - wrap o@[ LL _ (BodyStmt _ x _ _) - , LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ unit)))) _ _)] + wrap o@[ L _ (BodyStmt _ x _ _) + , L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _)] | returnsUnit x, occNameString (rdrNameOcc unit) == "()" = [warn' ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []] -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap - o@[g@(LL _ (BindStmt _ (view' -> PVar_' u) x _ _)) - , q@(LL _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))] + o@[g@(L _ (BindStmt _ (view' -> PVar_' u) x _ _)) + , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))] | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars' (f : fs) = - [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExt (noLoc $ OpApp noExt (foldl' (\acc e -> noLoc $ OpApp noExt acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]) + [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]) [Replace Stmt (toSS' g) (("x", toSS' x):zip vs (toSS' <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS' q)]] where isSimple (fromApps' -> xs) = all isAtom' (x : xs) vs = ('f':) . show <$> [0..] notDol :: LHsExpr GhcPs -> Bool - notDol (LL _ (OpApp _ _ op _)) = not $ isDol op + notDol (L _ (OpApp _ _ op _)) = not $ isDol op notDol _ = True monadStep _ _ = [] @@ -190,40 +204,39 @@ monadSteps _ _ = [] -- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'. -monadLet :: [ExprLStmt GhcPs] -> Maybe ([ExprLStmt GhcPs], [Refactoring R.SrcSpan]) -monadLet xs = if null rs then Nothing else Just (ys, rs) +monadLet :: [ExprLStmt GhcPs] -> [(ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)] +monadLet xs = mapMaybe mkLet xs where - (ys, catMaybes -> rs) = unzip $ map mkLet xs - vs = concatMap pvars' [p | (LL _ (BindStmt _ p _ _ _)) <- xs] + vs = concatMap pvars' [p | (L _ (BindStmt _ p _ _ _)) <- xs] - mkLet :: ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring R.SrcSpan)) - mkLet g@(LL _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ )) + mkLet :: ExprLStmt GhcPs -> Maybe (ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan) + mkLet x@(L _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ )) | p `notElem` vars' y, p `notElem` delete p vs - = (template p y, Just refact) + = Just (x, template p y, refact) where - refact = Replace Stmt (toSS' g) [("lhs", toSS' v), ("rhs", toSS' y)] + refact = Replace Stmt (toSS' x) [("lhs", toSS' v), ("rhs", toSS' y)] (unsafePrettyPrint $ template "lhs" (strToVar "rhs")) - mkLet x = (x, Nothing) + mkLet _ = Nothing template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs = let p = noLoc $ mkRdrUnqual (mkVarOcc lhs) - grhs = noLoc (GRHS noExt [] rhs) - grhss = GRHSs noExt [grhs] (noLoc (EmptyLocalBinds noExt)) - match = noLoc $ Match noExt (FunRhs p Prefix NoSrcStrict) [] grhss - fb = noLoc $ FunBind noExt p (MG noExt (noLoc [match]) Generated) WpHole [] + grhs = noLoc (GRHS noExtField [] rhs) + grhss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField)) + match = noLoc $ Match noExtField (FunRhs p Prefix NoSrcStrict) [] grhss + fb = noLoc $ FunBind noExtField p (MG noExtField (noLoc [match]) Generated) WpHole [] binds = unitBag fb - valBinds = ValBinds noExt binds [] - localBinds = noLoc $ HsValBinds noExt valBinds - in noLoc $ LetStmt noExt localBinds + valBinds = ValBinds noExtField binds [] + localBinds = noLoc $ HsValBinds noExtField valBinds + in noLoc $ LetStmt noExtField localBinds fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs) -fromApplies (LL _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x) -fromApplies (LL _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x +fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x) +fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x) fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs) -fromRet (LL _ (HsPar _ x)) = fromRet x -fromRet (LL _ (OpApp _ x (LL _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExt x z) -fromRet (LL _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) +fromRet (L _ (HsPar _ x)) = fromRet x +fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExtField x z) +fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -15,25 +15,25 @@ Don't suggest for FFI, since they match their C names -data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest -data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar +data Yes = Foo | Bar'Test +data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar @NoRefactor data No = a :::: b data Yes = Foo {bar_cap :: Int} data No = FOO | BarBAR | BarBBar -yes_foo = yes_foo + yes_foo -- yesFoo = ... -yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... +yes_foo = yes_foo + yes_foo -- yesFoo = ... @NoRefactor +yes_fooPattern Nothing = 0 -- yesFooPattern Nothing = ... @NoRefactor no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1 -semiring'laws = 1 -- semiringLaws = ... -data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB +semiring'laws = 1 +data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB @NoRefactor case_foo = 1 test_foo = 1 -cast_foo = 1 -- castFoo = ... +cast_foo = 1 -- castFoo = ... @NoRefactor replicateM_ = 1 _foo__ = 1 section_1_1 = 1 -runMutator# = 1 +runMutator# = 1 @NoRefactor foreign import ccall hexml_node_child :: IO () -} @@ -41,7 +41,7 @@ module Hint.Naming(namingHint) where -import Hint.Type (Idea,DeclHint',suggest',isSym,toSrcSpan',ghcModule) +import Hint.Type (Idea,DeclHint',suggest',toSrcSpan',ghcModule) import Data.Generics.Uniplate.Operations import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data @@ -52,12 +52,13 @@ import BasicTypes import FastString -import HsDecls -import HsExtension -import HsSyn +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs import OccName import SrcLoc +import Language.Haskell.GhclibParserEx.GHC.Hs.Decls import GHC.Util namingHint :: DeclHint' @@ -74,7 +75,7 @@ where suggestedNames = [ (originalName, suggestedName) - | not $ isForD' originalDecl + | not $ isForD originalDecl , originalName <- nubOrd $ getNames originalDecl , Just suggestedName <- [suggestName originalName] , not $ suggestedName `Set.member` seen @@ -82,23 +83,23 @@ replacedDecl = replaceNames suggestedNames originalDecl shorten :: LHsDecl GhcPs -> LHsDecl GhcPs -shorten (LL locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) FromSource) _ _))) = - 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 (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (L locMatches matches) FromSource) _ _))) = + L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) = + L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) -shortenMatch (LL locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = - LL locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} +shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) = + L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}} shortenMatch x = x shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs) -shortenLGRHS (LL locGRHS (GRHS ttg0 guards (LL locExpr _))) = - LL locGRHS (GRHS ttg0 guards (cL locExpr dots)) +shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = + L locGRHS (GRHS ttg0 guards (cL locExpr dots)) where dots :: HsExpr GhcPs - dots = HsLit NoExt (HsString (SourceText "...") (mkFastString "...")) + dots = HsLit noExtField (HsString (SourceText "...") (mkFastString "...")) shortenLGRHS x = x getNames :: LHsDecl GhcPs -> [String] @@ -109,13 +110,16 @@ concatMap (map unsafePrettyPrint . getConNames . unLoc) cons getConstructorNames _ = [] +isSym (x:_) = not $ isAlpha x || x `elem` "_'" +isSym _ = False + suggestName :: String -> Maybe String suggestName original | isSym original || good || not (any isLower original) || any isDigit original || any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing | otherwise = Just $ f original where - good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' original + good = all isAlphaNum $ drp '_' $ drp '#' $ filter (/= '\'') $ reverse $ drp '_' original drp x = dropWhile (== x) f xs = us ++ g ys diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs --- a/src/Hint/NewType.hs +++ b/src/Hint/NewType.hs @@ -5,24 +5,25 @@ quantified data types because it is not valid. -data Foo = Foo Int -- newtype Foo = Foo Int -data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) -data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show -data Foo a b = Foo a -- newtype Foo a b = Foo a +data Foo = Foo Int -- newtype Foo = Foo Int @NoRefactor: refactoring for "Use newtype" is not implemented +data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq) @NoRefactor +data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show @NoRefactor +data Foo a b = Foo a -- newtype Foo a b = Foo a @NoRefactor data Foo = Foo { field1, field2 :: Int} -data S a = forall b . Show b => S b -{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) +data S a = forall b . Show b => S b @NoRefactor: apply-refact 0.6 requires RankNTypes pragma +{-# LANGUAGE RankNTypes #-}; data S a = forall b . Show b => S b +{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a) @NoRefactor data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar data Foo a = Eq a => MkFoo a -data Foo a = () => Foo a -- newtype Foo a = Foo a -data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int -data A = A {b :: !C} -- newtype A = A {b :: C} -data A = A Int# +data Foo a = () => Foo a -- newtype Foo a = Foo a @NoRefactor +data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int @NoRefactor +data A = A {b :: !C} -- newtype A = A {b :: C} @NoRefactor +data A = A Int# @NoRefactor {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #) {-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)} -data A = A () -- newtype A = A () +data A = A () -- newtype A = A () @NoRefactor newtype Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) -- newtype Foo = Foo Int deriving stock Show @@ -33,8 +34,8 @@ import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN') import Data.List (isSuffixOf) -import HsDecls -import HsSyn +import GHC.Hs.Decls +import GHC.Hs import Outputable import SrcLoc @@ -49,12 +50,12 @@ newtypeHintDecl _ = [] newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea] -newTypeDerivingStrategiesHintDecl decl@(LL _ (TyClD _ (DataDecl _ _ _ _ dataDef))) = +newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) = [ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = [] hasAllStrategies :: HsDataDefn GhcPs -> Bool -hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (LL _ xs)) = all hasStrategyClause xs +hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs hasAllStrategies _ = False isData :: HsDataDefn GhcPs -> Bool @@ -63,7 +64,7 @@ isData _ = False hasStrategyClause :: LHsDerivingClause GhcPs -> Bool -hasStrategyClause (LL _ (HsDerivingClause _ (Just _) _)) = True +hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True hasStrategyClause _ = False data WarnNewtype = WarnNewtype @@ -79,12 +80,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 (LL loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [LL _ constructor] _)))) +singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [L _ constructor] _)))) | Just inType <- simpleCons constructor = Just WarnNewtype - { newDecl = LL loc $ TyClD ext decl {tcdDataDefn = dataDef + { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef { dd_ND = NewType - , dd_cons = map (\(LL consloc x) -> LL consloc $ dropConsBang x) $ dd_cons dataDef + , dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef }} , insideType = inType } @@ -93,12 +94,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 [LL _ inType]) _) +simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [L _ inType]) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType = Just inType -simpleCons (ConDeclH98 _ _ _ [] context (RecCon (LL _ [LL _ (ConDeclField _ [_] (LL _ inType) _)])) _) +simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _) | emptyOrNoContext context , not $ isUnboxedTuple inType , not $ isHashy inType @@ -115,18 +116,18 @@ emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool emptyOrNoContext Nothing = True -emptyOrNoContext (Just (LL _ [])) = True +emptyOrNoContext (Just (L _ [])) = 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 (LL recloc conDeclFields)) _) = +dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) = decl {con_args = RecCon $ cL recloc $ removeUnpacksRecords conDeclFields} where removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs] - removeUnpacksRecords = map (\(LL conDeclFieldLoc x) -> LL conDeclFieldLoc $ removeConDeclFieldUnpacks x) + removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x) removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) = diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs --- a/src/Hint/Pattern.hs +++ b/src/Hint/Pattern.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, PatternGuards #-} +{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-} {- Improve the structure of code @@ -16,7 +16,7 @@ | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y -foo x = x + x where -- foo x = x + x +foo x = x + x where -- @NoRefactor: refactoring for "Redundant where" is not implemented foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x @@ -25,28 +25,30 @@ foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x -foo = case v of !True -> x -- True -foo = case v of !(Just x) -> x -- (Just x) -foo = case v of !(x : xs) -> x -- (x:xs) -foo = case v of !1 -> x -- 1 -foo = case v of !x -> x -foo = case v of !(I# x) -> y -- (I# x) +foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2. +foo = case v of !True -> x -- True @NoRefactor: apply-refact requires BangPatterns pragma +{-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True +{-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x) +{-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs) +{-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1 +{-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x +{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) @NoRefactor foo = let ~x = 1 in y -- x foo = let ~(x:xs) = y in z -foo = let !x = undefined in y -foo = let !(I# x) = 4 in x -foo = let !(Just x) = Nothing in 3 -foo = 1 where f !False = 2 -- False -foo = 1 where !False = True -foo = 1 where g (Just !True) = Nothing -- True -foo = 1 where Just !True = Nothing -foo otherwise = 1 -- _ +{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y +{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x @NoRefactor +{-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3 +{-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False +{-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True +{-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True +{-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing +foo otherwise = 1 -- _ @NoRefactor foo ~x = y -- x {-# LANGUAGE Strict #-} foo ~x = y -foo !(x, y) = x -- (x, y) -foo ![x] = x -- [x] +{-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y) +{-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x] foo !Bar { bar = x } = x -- Bar { bar = x } -l !(() :: ()) = x -- (() :: ()) +{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ()) foo x@_ = x -- x foo x@Foo = x @@ -55,7 +57,7 @@ module Hint.Pattern(patternHint) where -import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan,ghcSpanToHSE,suggest',warn') +import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan',suggest',suggestRemove,warn') import Data.Generics.Uniplate.Operations import Data.Function import Data.List.Extra @@ -65,7 +67,7 @@ import Refact.Types hiding (RType(Pattern, Match), SrcSpan) import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) -import HsSyn +import GHC.Hs import SrcLoc import RdrName import OccName @@ -73,6 +75,7 @@ import BasicTypes import GHC.Util +import Language.Haskell.GhclibParserEx.GHC.Hs.Pat import Language.Haskell.GhclibParserEx.GHC.Hs.Expr patternHint :: DeclHint' @@ -80,16 +83,15 @@ concatMap (uncurry hints . swap) (asPattern x) ++ -- PatBind (used in 'let' and 'where') contains lazy-by-default -- patterns, everything else is strict. - concatMap (patHint strict False) (located [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]]) ++ - concatMap (patHint strict True) (located (universeBi $ transformBi noPatBind x)) ++ + concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++ + concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where - located ps = [p | p@XPat{} <- ps] -- restrict attention to patterns with locs exts = nubOrd $ concatMap snd (langExts (pragmas (ghcAnnotations modu))) -- language extensions enabled at source strict = "Strict" `elem` exts noPatBind :: LHsBind GhcPs -> LHsBind GhcPs - noPatBind (LL loc a@PatBind{}) = cL loc a{pat_lhs=noLoc (WildPat noExt)} + noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)} noPatBind x = x {- @@ -105,14 +107,14 @@ -} hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] -hints gen (Pattern l rtype pat (GRHSs _ [LL _ (GRHS _ [] bod)] bind)) - | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExt guards bind)) [refactoring]] +hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind)) + | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]] where rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)] rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)) - mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr noSyntaxExpr] + mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLoc . uncurry mkGuard) rawGuards @@ -123,8 +125,7 @@ -- Check if the expression has been injected or is natural. zipWith checkLoc ps ['1' .. '9'] where - checkLoc p@(LL l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p) - checkLoc _ v = undefined -- {-# COMPLETE LL #-} + checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p) patSubts = case pat of @@ -138,98 +139,103 @@ toString (Left e) = e toString (Right (v, _)) = strToVar v toString' (Left e) = e - toString' (Right (v, _)) = strToPat' v + toString' (Right (v, _)) = strToPat v - template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExt templateGuards bind)) []) + template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) []) f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] f = rights - refactoring = Replace rtype (toRefactSrcSpan$ ghcSpanToHSE l) (f patSubts ++ f guardSubts ++ f exprSubts) template -hints gen (Pattern l t pats o@(GRHSs _ [LL _ (GRHS _ [test] bod)] bind)) + refactoring = Replace rtype (toRefactSrcSpan' l) (f patSubts ++ f guardSubts ++ f exprSubts) template +hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) | unsafePrettyPrint test `elem` ["otherwise", "True"] - = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExt [] bod)]}) [Delete Stmt (toSS' test)]] -hints gen (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds - = [gen "Redundant where" (Pattern l t pats bod{grhssLocalBinds=noLoc (EmptyLocalBinds noExt)}) []] + = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS' test)]] +hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds + = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]] where f :: LHsLocalBinds GhcPs -> Bool - f (LL _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag - f (LL _ (HsIPBinds _ (IPBinds _ l))) = null l + f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag + f (L _ (HsIPBinds _ (IPBinds _ l))) = null l f _ = False -hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, LL _ (GRHS _ [test] bod))) binds)) + whereSpan = case l of + UnhelpfulSpan s -> UnhelpfulSpan s + RealSrcSpan s -> + let end = realSrcSpanEnd s + start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5) + in RealSrcSpan (mkRealSrcSpan start end) +hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True" = let tag = noLoc (mkRdrUnqual $ mkVarOcc "otherwise") - otherwise_ = noLoc $ BodyStmt noExt (noLoc (HsVar noExt tag)) noSyntaxExpr noSyntaxExpr in - [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExt [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]] + otherwise_ = noLoc $ BodyStmt noExtField (noLoc (HsVar noExtField tag)) noSyntaxExpr noSyntaxExpr in + [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]] hints _ _ = [] asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)] -asGuards (LL _ (HsPar _ x)) = asGuards x -asGuards (LL _ (HsIf _ _ a b c)) = (a, b) : asGuards c -asGuards x = [(noLoc (HsVar noExt (noLoc (mkRdrUnqual $ mkVarOcc "otherwise"))), x)] +asGuards (L _ (HsPar _ x)) = asGuards x +asGuards (L _ (HsIf _ _ a b c)) = (a, b) : asGuards c +asGuards x = [(noLoc (HsVar noExtField (noLoc (mkRdrUnqual $ mkVarOcc "otherwise"))), x)] -data Pattern = Pattern SrcSpan R.RType [Pat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) +data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) -- Invariant: Number of patterns may not change asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] -asPattern (LL loc x) = concatMap decl (universeBi x) +asPattern (L loc x) = concatMap decl (universeBi x) where decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] - decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (cL loc o :: LHsBind GhcPs) (noLoc (PatBind noExt pat rhs ([], [])) :: LHsBind GhcPs) rs)] - decl (FunBind _ _ (MG _ (LL _ xs) _) _ _) = map match xs + decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)] + decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs decl _ = [] match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) - match o@(LL loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExt ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs) - match _ = undefined -- {-# COMPLETE LL #-} -asPattern _ = [] -- {-# COMPLETE LL #-} + match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExtField ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs) + match _ = undefined -- {-# COMPLETE L #-} -- First Bool is if 'Strict' is a language extension. Second Bool is -- if this pattern in this context is going to be evaluated strictly. -patHint :: Bool -> Bool -> Pat GhcPs -> [Idea] -patHint _ _ o@(LL _ (ConPatIn name (PrefixCon args))) - | length args >= 3 && all isPWildCard' args = - let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (Pat GhcPs) - new = ConPatIn name (RecCon rec_fields) :: Pat GhcPs +patHint :: Bool -> Bool -> LPat GhcPs -> [Idea] +patHint _ _ o@(L _ (ConPatIn name (PrefixCon args))) + | length args >= 3 && all isPWildcard args = + let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs) + new = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs in [suggest' "Use record patterns" o new [Replace R.Pattern (toSS' o) [] (unsafePrettyPrint new)]] -patHint _ _ o@(LL _ (VarPat _ (L _ name))) +patHint _ _ o@(L _ (VarPat _ (L _ name))) | occNameString (rdrNameOcc name) == "otherwise" = - [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExt) :: Pat GhcPs) []] -patHint lang strict o@(LL _ (BangPat _ (LL _ x))) - | strict, f x = [warn' "Redundant bang pattern" o x [r]] + [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []] +patHint lang strict o@(L _ (BangPat _ pat@(L _ x))) + | strict, f x = [warn' "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]] where f :: Pat GhcPs -> Bool - f (ParPat _ (LL _ x)) = f x - f (AsPat _ _ (LL _ x)) = f x + f (ParPat _ (L _ x)) = f x + f (AsPat _ _ (L _ x)) = f x f LitPat {} = True f NPat {} = True f ConPatIn {} = True f TuplePat {} = True f ListPat {} = True - f (SigPat _ (LL _ p) _) = f p + f (SigPat _ (L _ p) _) = f p f _ = False - r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x" -patHint False _ o@(LL _ (LazyPat _ (LL _ x))) - | f x = [warn' "Redundant irrefutable pattern" o x [r]] + r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x" +patHint False _ o@(L _ (LazyPat _ pat@(L _ x))) + | f x = [warn' "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]] where f :: Pat GhcPs -> Bool - f (ParPat _ (LL _ x)) = f x - f (AsPat _ _ (LL _ x)) = f x + f (ParPat _ (L _ x)) = f x + f (AsPat _ _ (L _ x)) = f x f WildPat{} = True f VarPat{} = True f _ = False - r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x" -patHint _ _ o@(LL _ (AsPat _ v (LL _ (WildPat _)))) = + r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x" +patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) = [warn' "Redundant as-pattern" o v []] patHint _ _ _ = [] expHint :: LHsExpr GhcPs -> [Idea] -- Note the 'FromSource' in these equations (don't warn on generated match groups). -expHint o@(LL _ (HsCase _ _ (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (WildPat _)] (GRHSs _ [LL _ (GRHS _ [] e)] (LL _ (EmptyLocalBinds _)))) ]) FromSource ))) = +expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) = [suggest' "Redundant case" o e [r]] where r = Replace Expr (toSS' o) [("x", toSS' e)] "x" -expHint o@(LL _ (HsCase _ (LL _ (HsVar _ (L _ x))) (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (VarPat _ (L _ y))] (GRHSs _ [LL _ (GRHS _ [] e)] (LL _ (EmptyLocalBinds _)))) ]) FromSource ))) +expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) | occNameString (rdrNameOcc x) == occNameString (rdrNameOcc y) = [suggest' "Redundant case" o e [r]] where diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -14,12 +14,13 @@ {-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-} -{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? +{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} +{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag +{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} @NoRefactor: the two pragmas are switched in the refactoring output {-# OPTIONS_GHC -cpp #-} \ -{-# LANGUAGE CPP, Text #-} -- +{-# LANGUAGE CPP, Text #-} -- @NoRefactor {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \ @@ -30,7 +31,7 @@ module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea',prettyExtension,glasgowExts) +import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea') import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe @@ -41,6 +42,7 @@ import SrcLoc import GHC.Util +import DynFlags pragmaHint :: ModuHint pragmaHint _ modu = @@ -97,10 +99,10 @@ mkLanguage = rawIdea' Hint.Type.Warning "Use LANGUAGE pragmas" languageDupes :: [(Located AnnotationComment, [String])] -> [Idea] -languageDupes ( (a@(LL l _), les) : cs ) = +languageDupes ( (a@(L 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'] + else [pragmaIdea (MultiComment a b (mkLangExts l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les'] ) ++ languageDupes cs languageDupes _ = [] @@ -108,7 +110,7 @@ strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] -strToLanguage "-fglasgow-exts" = Just $ map prettyExtension glasgowExts +strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags strToLanguage _ = Nothing -- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma, @@ -126,7 +128,7 @@ optToLanguage :: (Located AnnotationComment, [String]) -> [String] -> Maybe (Maybe (Located AnnotationComment), [String]) -optToLanguage (LL loc _, flags) langExts +optToLanguage (L 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 diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -29,7 +29,7 @@ import Control.Monad import Prelude -import HsSyn +import GHC.Hs import RdrName import ApiAnnotation import Module @@ -114,7 +114,7 @@ | not allowIdent -> ideaNoTo $ warn' "Avoid restricted identifiers" i i [] | not allowQual -> warn' "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) [] | otherwise -> error "checkImports: unexpected case" - | i@(LL _ ImportDecl {..}) <- imp + | i@(L _ ImportDecl {..}) <- imp , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp , let allowImport = within modu "" ri , let allowIdent = Set.disjoint diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs --- a/src/Hint/Smell.hs +++ b/src/Hint/Smell.hs @@ -86,7 +86,7 @@ import qualified Data.Map as Map import BasicTypes -import HsSyn +import GHC.Hs import RdrName import Outputable import Bag @@ -130,10 +130,10 @@ -- right hand sides?) declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)] declSpans - (LL _ (ValD _ + (L _ (ValD _ FunBind {fun_matches=MG { mg_origin=FromSource - , mg_alts=(LL _ [LL _ Match { + , mg_alts=(L _ [L _ Match { m_ctxt=ctx , m_grhss=GRHSs{grhssGRHSs=[locGrhs] , grhssLocalBinds=where_}}])}})) = @@ -141,20 +141,20 @@ -- 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 f@(L l (ValD _ FunBind {})) = [(l, warn' "Long function" f f [])] declSpans _ = [] -- 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 _))) = +rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass +rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) = [(l, rawIdea' Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] rhsSpans _ _ = [] -- 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 (L l (HsValBinds _ (ValBinds _ bs _))) = + concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs) whereSpans _ = [] spanLength :: SrcSpan -> Int @@ -162,7 +162,7 @@ spanLength (UnhelpfulSpan _) = -1 smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea] -smellLongTypeLists d@(LL _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (LL _ t)))))) n = +smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n = warn' "Long type list" d d [] <$ filter longTypeList (universe t) where longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n @@ -170,7 +170,7 @@ smellLongTypeLists _ _ = [] smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea] -smellManyArgFunctions d@(LL _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (LL _ t)))))) n = +smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n = warn' "Many arg function" d d [] <$ filter manyArgFunction (universe t) where manyArgFunction t = countFunctionArgs t >= n diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs --- a/src/Hint/Type.hs +++ b/src/Hint/Type.hs @@ -1,6 +1,6 @@ module Hint.Type( - DeclHint, DeclHint', ModuHint, CrossHint, Hint(..), + DeclHint', ModuHint, CrossHint, Hint(..), module Export ) where @@ -10,12 +10,11 @@ import Idea as Export import Prelude import Refact as Export -import HsExtension -import HsDecls +import GHC.Hs.Extension +import GHC.Hs.Decls 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,19 +22,17 @@ data Hint {- PUBLIC -} = Hint { hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's. , hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's. - , hintDecl :: [Setting] -> Scope -> ModuleEx -> 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. } instance Semigroup Hint where - Hint x1 x2 x3 x4 <> Hint y1 y2 y3 y4 = Hint + Hint x1 x2 x3 <> Hint y1 y2 y3 = Hint (\a b -> x1 a b ++ y1 a b) (\a b c -> x2 a b c ++ y2 a b c) (\a b c d -> x3 a b c d ++ y3 a b c d) - (\a b c d -> x4 a b c d ++ y4 a b c d) instance Monoid Hint where - mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) (\_ _ _ _ -> []) + mempty = Hint (\_ _ -> []) (\_ _ _ -> []) (\_ _ _ _ -> []) mappend = (<>) diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs --- a/src/Hint/Unsafe.hs +++ b/src/Hint/Unsafe.hs @@ -19,11 +19,11 @@ module Hint.Unsafe(unsafeHint) where import Hint.Type(DeclHint',ModuleEx(..),Severity(..),rawIdea',toSS') -import Data.Char +import Data.List.Extra import Refact.Types hiding(Match) import Data.Generics.Uniplate.Operations -import HsSyn +import GHC.Hs import OccName import RdrName import FastString @@ -45,10 +45,10 @@ -- @ -- is. We advise that such constants should have a @NOINLINE@ pragma. unsafeHint :: DeclHint' -unsafeHint _ (ModuleEx _ _ (L _ m) _) = \(L loc d) -> +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) + (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d) [] [InsertComment (toSS' (L loc d)) (unsafePrettyPrint $ gen x)] -- 'x' does not declare a new function. | d@(ValD _ @@ -61,26 +61,26 @@ where gen :: OccName -> LHsDecl GhcPs gen x = noLoc $ - SigD noExt (InlineSig noExt (noLoc (mkRdrUnqual x)) + SigD noExtField (InlineSig noExtField (noLoc (mkRdrUnqual x)) (InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike)) noinline :: [OccName] - noinline = [q | LL _(SigD _ (InlineSig _ (L _ (Unqual q)) + noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q)) (InlinePragma _ NoInline Nothing NeverActive FunLike)) ) <- hsmodDecls m] isUnsafeDecl :: HsDecl GhcPs -> Bool -isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=LL _ alts}}) = +isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=L _ alts}}) = any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False -- Am I equivalent to @unsafePerformIO x@? isUnsafeApp :: HsExpr GhcPs -> Bool -isUnsafeApp (OpApp _ (LL _ l) op _ ) | isDol op = isUnsafeFun l -isUnsafeApp (HsApp _ (LL _ x) _) = isUnsafeFun x +isUnsafeApp (OpApp _ (L _ l) op _ ) | isDol op = isUnsafeFun l +isUnsafeApp (HsApp _ (L _ x) _) = isUnsafeFun x isUnsafeApp _ = False -- Am I equivalent to @unsafePerformIO . x@? isUnsafeFun :: HsExpr GhcPs -> Bool -isUnsafeFun (HsVar _ (LL _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True -isUnsafeFun (OpApp _ (LL _ l) op _) | isDot op = isUnsafeFun l +isUnsafeFun (HsVar _ (L _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True +isUnsafeFun (OpApp _ (L _ l) op _) | isDot op = isUnsafeFun l isUnsafeFun _ = False diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs deleted file mode 100644 --- a/src/Hint/Util.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE PatternGuards, ViewPatterns #-} - -module Hint.Util(niceLambdaR) where - -import HSE.All -import Data.List.Extra -import Refact.Types -import Refact -import qualified Refact.Types as R (SrcSpan) - --- | Generate a lambda, but prettier (if possible). --- Generally no lambda is good, but removing just some arguments isn't so useful. -niceLambdaR :: [String] -> Exp_ -> (Exp_, R.SrcSpan -> [Refactoring R.SrcSpan]) - --- \xs -> (e) ==> \xs -> e -niceLambdaR xs (Paren l x) = niceLambdaR xs x - --- \xs -> \v vs -> e ==> \xs v -> \vs -> e --- \xs -> \ -> e ==> \xs -> e -niceLambdaR xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambdaR (xs++[v]) (Lambda an vs x) -niceLambdaR xs (Lambda _ [] x) = niceLambdaR xs x - --- \ -> e ==> e -niceLambdaR [] x = (x, const []) - --- \vs v -> e $ v ==> \vs -> e -niceLambdaR (unsnoc -> Just (vs, v)) (InfixApp _ e (isDol -> True) (view -> Var_ v2)) - | v == v2, vars e `disjoint` [v] - = niceLambdaR vs e - --- \xs -> e xs ==> e -niceLambdaR xs (fromAppsWithLoc -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 = - (apps e2, \s -> [Replace Expr s [("x", pos)] "x"]) - where (e',xs') = splitAt (length e - length xs) e - (e2, xs2) = (map fst e', map fst xs') - pos = toRefactSrcSpan . srcInfoSpan $ snd (last e') - --- \x y -> x + y ==> (+) -niceLambdaR [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1)) - | x == x1, y == y1, vars op `disjoint` [x,y] = (op, \s -> [Replace Expr s [] (prettyPrint op)]) - --- \x -> x + a ==> (+ a) [heuristic, ab must be a single lexeme, or gets too complex] -niceLambdaR [x] (view -> App2 (expOp -> Just op) xx a) - | isLexeme a, view xx == Var_ x, x `notElem` vars a, allowRightSection (fromNamed op) = - let e = rebracket1 $ RightSection an op a - in (e, \s -> [Replace Expr s [] (prettyPrint e)]) - --- \x -> a + x ==> (a +) [heuristic, a must be a single lexeme, or gets too complex] -niceLambdaR [x] (view -> App2 (expOp -> Just op) a xx) - | isLexeme a, view xx == Var_ x, x `notElem` vars a = - let e = rebracket1 $ LeftSection an a op - in (e, \s -> [Replace Expr s [] (prettyPrint e)]) - --- \x y -> f y x = flip f -niceLambdaR [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) - | x == x1, y == y1, vars op `disjoint` [x,y] = (gen op, \s -> [Replace Expr s [("x", toSS op)] (prettyPrint $ gen (toNamed "x"))]) - where - gen = App an (toNamed "flip") - --- \x -> f (b x) ==> f . b --- \x -> f $ b x ==> f . b -niceLambdaR [x] y | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s]) - where - -- factor the expression with respect to x - factor y@(App _ ini lst) | view lst == Var_ x = Just (ini, [ann ini]) - factor y@(App _ ini lst) | Just (z, ss) <- factor lst = let r = niceDotApp ini z - in if r == z then Just (r, ss) - else Just (r, ann ini : ss) - factor (InfixApp _ y op (factor -> Just (z, ss))) | isDol op = let r = niceDotApp y z - in if r == z then Just (r, ss) - else Just (r, ann y : ss) - factor (Paren _ y@App{}) = factor y - factor _ = Nothing - mkRefact :: [S] -> R.SrcSpan -> Refactoring R.SrcSpan - mkRefact subts s = - let tempSubts = zipWith (\a b -> ([a], toRefactSrcSpan $ srcInfoSpan b)) ['a' .. 'z'] subts - template = dotApps (map (toNamed . fst) tempSubts) - in Replace Expr s tempSubts (prettyPrint template) - - --- \x -> (x +) ==> (+) --- Section handling is not yet supported for refactoring -niceLambdaR [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 = - let e = opExp op - in (e, \s -> [Replace Expr s [] (prettyPrint e)]) - --- base case -niceLambdaR ps x = (Lambda an (map toNamed ps) x, const []) - - - --- ($) . b ==> b -niceDotApp :: Exp_ -> Exp_ -> Exp_ -niceDotApp a b | a ~= "$" = b - | otherwise = dotApp a b diff --git a/src/HsColour.hs b/src/HsColour.hs --- a/src/HsColour.hs +++ b/src/HsColour.hs @@ -4,7 +4,7 @@ #ifdef GPL_SCARES_ME hsColourConsole :: IO (String -> String) -hsColourConsole = return id +hsColourConsole = pure id hsColourHTML :: String -> String hsColourHTML = id diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -2,8 +2,8 @@ module Idea( Idea(..), - rawIdea, rawIdea', idea, idea', suggest, suggest', warn, warn',ignore, ignore', - rawIdeaN, rawIdeaN', suggestN, suggestN', ignoreN, ignoreN', ignoreNoSuggestion', + rawIdea', idea', suggest', suggestRemove, warn', warnRemove, ignore', + rawIdeaN, rawIdeaN', suggestN', ignoreNoSuggestion', showIdeasJson, showANSI, Note(..), showNotes, Severity(..), @@ -11,7 +11,6 @@ import Data.Functor import Data.List.Extra -import HSE.All import Config.Type import HsColour import Refact.Types hiding (SrcSpan) @@ -27,7 +26,7 @@ ,ideaDecl :: [String] -- ^ The declarations the idea is for, usually a singleton, typically the function name, but may be a type name. ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'. ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@. - ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to. + ,ideaSpan :: GHC.SrcSpan -- ^ The source code the idea relates to. ,ideaFrom :: String -- ^ The contents of the source code the idea relates to. ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors). ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement. @@ -39,15 +38,15 @@ -- 1) Aeson doesn't esape unicode characters, and I want to (allows me to ignore encoding) -- 2) I want to control the format so it's slightly human readable as well showIdeaJson :: Idea -> String -showIdeaJson idea@Idea{ideaSpan=srcSpan@SrcSpan{..}, ..} = dict +showIdeaJson idea@Idea{ideaSpan=srcSpan@GHC.SrcSpan{..}, ..} = dict [("module", list $ map str ideaModule) ,("decl", list $ map str ideaDecl) ,("severity", str $ show ideaSeverity) ,("hint", str ideaHint) ,("file", str srcSpanFilename) - ,("startLine", show srcSpanStartLine) + ,("startLine", show srcSpanStartLine') ,("startColumn", show srcSpanStartColumn) - ,("endLine", show srcSpanEndLine) + ,("endLine", show srcSpanEndLine') ,("endColumn", show srcSpanEndColumn) ,("from", str ideaFrom) ,("to", maybe "null" str ideaTo) @@ -71,7 +70,7 @@ showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $ - [showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++ + [GHC.showSrcSpan' ideaSpan ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++ f "Found" (Just ideaFrom) ++ f "Perhaps" ideaTo ++ ["Note: " ++ n | let n = showNotes ideaNote, n /= ""] where @@ -81,76 +80,53 @@ where xs = lines $ tt x -rawIdea :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea +rawIdea :: Severity -> String -> GHC.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) +rawIdea' = Idea [] [] -rawIdeaN :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea +rawIdeaN :: Severity -> String -> GHC.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 +rawIdeaN' a b span d e f = Idea [] [] a b span d e f [] 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) [] + rawIdea severity hint (GHC.getLoc from) (GHC.unsafePrettyPrint from) (Just $ GHC.unsafePrettyPrint to) [] -suggest :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) => - String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea -suggest = idea Suggestion +-- Construct an Idea that suggests "Perhaps you should remove it." +ideaRemove :: Severity -> String -> GHC.SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea +ideaRemove severity hint span from = rawIdea severity hint span from (Just "") [] 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 +suggestRemove :: String -> GHC.SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea +suggestRemove = ideaRemove Suggestion warn' :: (GHC.HasSrcSpan a, Outputable.Outputable a, GHC.HasSrcSpan b, Outputable.Outputable b) => String -> a -> b -> [Refactoring R.SrcSpan] -> Idea warn' = idea' Warning +warnRemove :: String -> GHC.SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea +warnRemove = ideaRemove Warning + ignoreNoSuggestion' :: (GHC.HasSrcSpan a, Outputable.Outputable a) => String -> a -> Idea -ignoreNoSuggestion' hint x = rawIdeaN Ignore hint (ghcSpanToHSE (GHC.getLoc x)) (GHC.unsafePrettyPrint x) Nothing [] - -ignore :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) => - String -> ast SrcSpanInfo -> a -> [Refactoring R.SrcSpan] -> Idea -ignore = idea Ignore +ignoreNoSuggestion' hint x = rawIdeaN Ignore hint (GHC.getLoc x) (GHC.unsafePrettyPrint x) Nothing [] ignore' :: (GHC.HasSrcSpan a, Outputable.Outputable a) => String -> a -> a -> [Refactoring R.SrcSpan] -> Idea ignore' = idea' Ignore -ideaN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) => - Severity -> String -> ast SrcSpanInfo -> a -> Idea -ideaN severity hint from to = idea severity hint from to [] - ideaN' :: (GHC.HasSrcSpan a, Outputable.Outputable a) => Severity -> String -> a -> a -> Idea ideaN' severity hint from to = idea' severity hint from to [] -suggestN :: (Annotated ast, Pretty a, Pretty (ast SrcSpanInfo)) => - String -> ast SrcSpanInfo -> a -> Idea -suggestN = ideaN Suggestion - suggestN' :: (GHC.HasSrcSpan a, Outputable.Outputable a) => String -> a -> a -> Idea suggestN' = ideaN' Suggestion - -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/HLint.hs b/src/Language/Haskell/HLint.hs --- a/src/Language/Haskell/HLint.hs +++ b/src/Language/Haskell/HLint.hs @@ -1,43 +1,152 @@ -{-| -/WARNING: This module represents the old version of the HLint API./ -/It will be deleted in favour of "Language.Haskell.HLint3" in the next major version./ - -This module provides a library interface to HLint, strongly modelled on the command line interface. --} +{-# LANGUAGE PatternGuards, RecordWildCards #-} -module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where +-- | This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process +-- and collect the results see 'hlint'. +-- +-- If you want to approximate the @hlint@ experience with +-- a more structured API try: +-- +-- @ +-- (flags, classify, hint) <- 'autoSettings' +-- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing +-- print $ 'applyHints' classify hint [m] +-- @ +module Language.Haskell.HLint( + -- * Generate hints + hlint, applyHints, + -- * Idea data type + Idea(..), Severity(..), Note(..), + -- * Settings + Classify(..), + getHLintDataDir, autoSettings, argsSettings, + findSettings, readSettingsFile, + -- * Hints + Hint, + -- * Modules + ModuleEx, parseModuleEx, createModuleEx, ParseError(..), + -- * Parse flags + defaultParseFlags, + ParseFlags(..), CppFlags(..), FixityInfo, + parseFlagsAddFixities, + ) where -import qualified HLint import Config.Type +import Config.Read +import Control.Exception.Extra import Idea +import qualified Apply as H +import HLint +import Fixity import HSE.All +import Hint.All hiding (resolveHints) +import qualified Hint.All as H +import qualified ApiAnnotation as GHC +import qualified GHC.Hs as GHC +import SrcLoc +import CmdLine +import Paths_hlint +import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx +import Data.List.Extra +import Data.Maybe +import System.FilePath +import Data.Functor +import Prelude --- | This function takes a list of command line arguments, and returns the given suggestions. --- To see a list of arguments type @hlint --help@ at the console. --- This function writes to the stdout/stderr streams, unless @--quiet@ is specified. + +-- | Get the Cabal configured data directory of HLint. +getHLintDataDir :: IO FilePath +getHLintDataDir = getDataDir + + +-- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'), +-- and 'Classify' and 'Hint' for 'applyHints'. +-- It approximates the normal HLint configuration steps, roughly: -- --- As an example: +-- 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files. -- --- > do hints <- hlint ["src", "--ignore=Use map","--quiet"] --- > when (length hints > 3) $ error "Too many hints!" -hlint :: [String] -> IO [Suggestion] -hlint = fmap (map Suggestion_) . HLint.hlint +-- 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'. +-- +-- If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs, +-- loading hints from a database) you are expected to copy and paste this function, then change it to your needs. +autoSettings :: IO (ParseFlags, [Classify], Hint) +autoSettings = do + (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing + pure (parseFlagsAddFixities fixities defaultParseFlags, classify, hints) +-- | A version of 'autoSettings' which respects some of the arguments supported by HLint. +-- If arguments unrecognised by HLint are used it will result in an error. +-- Arguments which have no representation in the return type are silently ignored. +argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint) +argsSettings args = do + cmd <- getCmd args + case cmd of + CmdMain{..} -> do + -- FIXME: One thing that could be supported (but isn't) is 'cmdGivenHints' + (_,settings) <- readAllSettings args cmd + let (fixities, classify, hints) = splitSettings settings + let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ + defaultParseFlags{cppFlags = cmdCpp cmd} + let ignore = [Classify Ignore x "" "" | x <- cmdIgnore] + pure (flags, classify ++ ignore, hints) + _ -> errorIO "Can only invoke autoSettingsArgs with the root process" --- | A suggestion - the @Show@ instance is of particular use. -newtype Suggestion = Suggestion_ {fromSuggestion :: Idea} - deriving (Eq,Ord) -instance Show Suggestion where - show = show . fromSuggestion +-- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name +-- (e.g. @HLint.Default@), find the settings file associated with it, returning the +-- name of the file, and (optionally) the contents. +-- +-- This function looks for all settings files starting with @HLint.@ in the directory +-- argument, and all other files relative to the current directory. +readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String) +readSettingsFile dir x + | takeExtension x `elem` [".yml",".yaml"] = do + dir <- maybe getHLintDataDir pure dir + pure (dir x, Nothing) + | Just x <- "HLint." `stripPrefix` x = do + dir <- maybe getHLintDataDir pure dir + pure (dir x <.> "hs", Nothing) + | otherwise = pure (x <.> "hs", Nothing) --- | From a suggestion, extract the file location it refers to. -suggestionLocation :: Suggestion -> SrcLoc -suggestionLocation = getPointLoc . ideaSpan . fromSuggestion +-- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from +-- (defaults to @hlint.yaml@) find the information from all settings files. +findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([FixityInfo], [Classify], Hint) +findSettings load start = do + (file,contents) <- load $ fromMaybe "hlint.yaml" start + splitSettings <$> readFilesConfig [(file,contents)] --- | From a suggestion, determine how severe it is. -suggestionSeverity :: Suggestion -> Severity -suggestionSeverity = ideaSeverity . fromSuggestion +-- | Split a list of 'Setting' for separate use in parsing and hint resolution +splitSettings :: [Setting] -> ([FixityInfo], [Classify], Hint) +splitSettings xs = + ([x | Infix x <- xs] + ,[x | SettingClassify x <- xs] + ,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left enumerate) + + +-- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. +-- The 'Idea' values will be ordered within a file. +-- +-- Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list. +-- When given multiple modules at once this function attempts to find hints between modules, +-- which is slower and often pointless (by default HLint passes modules singularly, using +-- @--cross@ to pass all modules together). +applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea] +applyHints = H.applyHints + +-- | Snippet from the documentation, if this changes, update the documentation +_docs :: IO () +_docs = do + (flags, classify, hint) <- autoSettings + Right m <- parseModuleEx flags "MyFile.hs" Nothing + print $ applyHints classify hint [m] + + +-- | Create a 'ModuleEx' from GHC annotations and module tree. It +-- is assumed the incoming parse module has not been adjusted to +-- account for operator fixities. +createModuleEx:: GHC.ApiAnns -> Located (GHC.HsModule GHC.GhcPs) -> ModuleEx +createModuleEx anns ast = + -- Use builtin fixities. + ModuleEx (GhclibParserEx.applyFixities [] ast) anns diff --git a/src/Language/Haskell/HLint3.hs b/src/Language/Haskell/HLint3.hs deleted file mode 100644 --- a/src/Language/Haskell/HLint3.hs +++ /dev/null @@ -1,7 +0,0 @@ - --- | A reexport of "Language.Haskell.HLint4" for compatibility purposes. -module Language.Haskell.HLint3( - module Language.Haskell.HLint4 - ) where - -import Language.Haskell.HLint4 diff --git a/src/Language/Haskell/HLint4.hs b/src/Language/Haskell/HLint4.hs deleted file mode 100644 --- a/src/Language/Haskell/HLint4.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE PatternGuards, RecordWildCards #-} - --- | /WARNING: This module represents the evolving version of the HLint API./ --- /It will be renamed to drop the "4" in the next major version./ --- --- This module provides a way to apply HLint hints. If you want to just run @hlint@ in-process --- and collect the results see 'hlint'. If you want to approximate the @hlint@ experience with --- a more structured API try: --- --- @ --- (flags, classify, hint) <- 'autoSettings' --- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing --- print $ 'applyHints' classify hint [m] --- @ -module Language.Haskell.HLint4( - hlint, applyHints, - -- * Idea data type - Idea(..), Severity(..), Note(..), - -- * Settings - Classify(..), - getHLintDataDir, autoSettings, argsSettings, - findSettings, readSettingsFile, - -- * Hints - Hint, resolveHints, - -- * Parse files - ModuleEx, parseModuleEx, createModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..) - ) where - -import Config.Type -import Config.Read -import Idea -import qualified Apply as H -import HLint -import HSE.All -import Hint.All hiding (resolveHints) -import qualified Hint.All as H -import qualified ApiAnnotation as GHC -import qualified HsSyn as GHC -import SrcLoc -import CmdLine -import Paths_hlint -import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx - -import Data.List.Extra -import Data.Maybe -import System.FilePath -import Data.Functor -import Prelude - - --- | Get the Cabal configured data directory of HLint. -getHLintDataDir :: IO FilePath -getHLintDataDir = getDataDir - - --- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'), --- and 'Classify' and 'Hint' for 'applyHints'. --- It approximates the normal HLint configuration steps, roughly: --- --- 1. Use 'findSettings' with 'readSettingsFile' to find and load the HLint settings files. --- --- 1. Use 'parseFlagsAddFixities' and 'resolveHints' to transform the outputs of 'findSettings'. --- --- If you want to do anything custom (e.g. using a different data directory, storing intermediate outputs, --- loading hints from a database) you are expected to copy and paste this function, then change it to your needs. -autoSettings :: IO (ParseFlags, [Classify], Hint) -autoSettings = do - (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) Nothing - return (parseFlagsAddFixities fixities defaultParseFlags, classify, hints) - - --- | The identity function. In previous versions of HLint this function was useful. Now, it isn't. -resolveHints :: Hint -> Hint -resolveHints = id - --- | A version of 'autoSettings' which respects some of the arguments supported by HLint. --- If arguments unrecognised by HLint are used it will result in an error. --- Arguments which have no representation in the return type are silently ignored. -argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint) -argsSettings args = do - cmd <- getCmd args - case cmd of - CmdMain{..} -> do - -- FIXME: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'. - (_,settings) <- readAllSettings args cmd - let (fixities, classify, hints) = splitSettings settings - let flags = parseFlagsSetLanguage (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ - defaultParseFlags{cppFlags = cmdCpp cmd} - let ignore = [Classify Ignore x "" "" | x <- cmdIgnore] - return (flags, classify ++ ignore, hints) - _ -> error "Can only invoke autoSettingsArgs with the root process" - - --- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name --- (e.g. @HLint.Default@), find the settings file associated with it, returning the --- name of the file, and (optionally) the contents. --- --- This function looks for all settings files starting with @HLint.@ in the directory --- argument, and all other files relative to the current directory. -readSettingsFile :: Maybe FilePath -> String -> IO (FilePath, Maybe String) -readSettingsFile dir x - | takeExtension x `elem` [".yml",".yaml"] = do - dir <- maybe getHLintDataDir return dir - return (dir x, Nothing) - | Just x <- "HLint." `stripPrefix` x = do - dir <- maybe getHLintDataDir return dir - return (dir x <.> "hs", Nothing) - | otherwise = return (x <.> "hs", Nothing) - - --- | Given a function to load a module (typically 'readSettingsFile'), and a module to start from --- (defaults to @hlint.yaml@) find the information from all settings files. -findSettings :: (String -> IO (FilePath, Maybe String)) -> Maybe String -> IO ([Fixity], [Classify], Hint) -findSettings load start = do - (file,contents) <- load $ fromMaybe "hlint.yaml" start - splitSettings <$> readFilesConfig [(file,contents)] - --- | Split a list of 'Setting' for separate use in parsing and hint resolution -splitSettings :: [Setting] -> ([Fixity], [Classify], Hint) -splitSettings xs = - ([x | Infix x <- xs] - ,[x | SettingClassify x <- xs] - ,H.resolveHints $ [Right x | SettingMatchExp x <- xs] ++ map Left [minBound..maxBound]) - - --- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. --- The 'Idea' values will be ordered within a file. --- --- Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list. --- When given multiple modules at once this function attempts to find hints between modules, --- which is slower and often pointless (by default HLint passes modules singularly, using --- @--cross@ to pass all modules together). -applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea] -applyHints = H.applyHints - --- | Snippet from the documentation, if this changes, update the documentation -_docs :: IO () -_docs = do - (flags, classify, hint) <- autoSettings - Right m <- parseModuleEx flags "MyFile.hs" Nothing - print $ applyHints classify hint [m] - - --- | 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 = - -- Use builtin fixities. - ModuleEx empty [] (GhclibParserEx.applyFixities [] ast) anns - where empty = Module an Nothing [] [] [] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,7 @@ module Main(main) where -import Language.Haskell.HLint3 +import Language.Haskell.HLint import Control.Monad import System.Environment import System.Exit diff --git a/src/Parallel.hs b/src/Parallel.hs --- a/src/Parallel.hs +++ b/src/Parallel.hs @@ -3,7 +3,7 @@ import Control.Parallel.Strategies parallel :: [IO [a]] -> IO [[a]] -parallel = return . withStrategy (parList $ seqList r0) . map unsafePerformIO +parallel = pure . withStrategy (parList $ seqList r0) . map unsafePerformIO However, this version performs about 10% slower with 2 processors in GHC 6.12.1 -} @@ -21,11 +21,11 @@ parallel1 :: [IO a] -> IO [a] -parallel1 [] = return [] +parallel1 [] = pure [] parallel1 (x:xs) = do x2 <- x xs2 <- unsafeInterleaveIO $ parallel1 xs - return $ x2:xs2 + pure $ x2:xs2 parallelN :: Int -> [IO a] -> IO [a] @@ -40,7 +40,7 @@ f chan = do v <- readChan chan case v of - Nothing -> return () + Nothing -> pure () Just (m,x) -> do putMVar m =<< try x f chan diff --git a/src/Refact.hs b/src/Refact.hs --- a/src/Refact.hs +++ b/src/Refact.hs @@ -1,34 +1,67 @@ +{-# LANGUAGE LambdaCase #-} + module Refact - ( toRefactSrcSpan - , toSS, toSS' + ( toRefactSrcSpan' + , toSS' , toSrcSpan' + , checkRefactor, refactorPath, runRefactoring ) where +import Control.Exception.Extra +import Control.Monad +import Data.Maybe +import Data.Version.Extra +import System.Directory.Extra +import System.Exit +import System.IO.Extra +import System.Process.Extra import qualified Refact.Types as R -import HSE.All import qualified SrcLoc as GHC -toRefactSrcSpan :: SrcSpan -> R.SrcSpan -toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss) - (srcSpanStartColumn ss) - (srcSpanEndLine ss) - (srcSpanEndColumn ss) - -toSS :: Annotated a => a S -> R.SrcSpan -toSS = toRefactSrcSpan . srcInfoSpan . ann - --- | Don't crash in case ghc gives us a \"fake\" span, --- opting instead to show @0 0 0 0@ coordinates. -toSrcSpan' :: GHC.HasSrcSpan a => a -> R.SrcSpan -toSrcSpan' x = case GHC.getLoc x of +toRefactSrcSpan' :: GHC.SrcSpan -> R.SrcSpan +toRefactSrcSpan' = \case GHC.RealSrcSpan span -> R.SrcSpan (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span) (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span) GHC.UnhelpfulSpan _ -> - R.SrcSpan 0 0 0 0 + R.SrcSpan (-1) (-1) (-1) (-1) +-- | Don't crash in case ghc gives us a \"fake\" span, +-- opting instead to show @-1 -1 -1 -1@ coordinates. +toSrcSpan' :: GHC.HasSrcSpan a => a -> R.SrcSpan +toSrcSpan' = toRefactSrcSpan' . GHC.getLoc + toSS' :: GHC.HasSrcSpan e => e -> R.SrcSpan -toSS' = toRefactSrcSpan . ghcSpanToHSE . GHC.getLoc +toSS' = toSrcSpan' + +checkRefactor :: Maybe FilePath -> IO FilePath +checkRefactor = refactorPath >=> either errorIO pure + +refactorPath :: Maybe FilePath -> IO (Either String FilePath) +refactorPath rpath = do + let excPath = fromMaybe "refactor" rpath + mexc <- findExecutable excPath + case mexc of + Just exc -> do + ver <- readVersion . tail <$> readProcess exc ["--version"] "" + pure $ if versionBranch ver >= [0,1,0,0] + then Right exc + else Left "Your version of refactor is too old, please upgrade to the latest version" + Nothing -> pure $ Left $ unlines + [ "Could not find 'refactor' executable" + , "Tried to find '" ++ excPath ++ "' on the PATH" + , "'refactor' is provided by the 'apply-refact' package and has to be installed" + , "" + ] + +runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode +runRefactoring rpath fin hints opts = do + let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints] + (_, _, _, phand) <- createProcess $ proc rpath args + try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) + hSetBuffering stdout LineBuffering + -- Propagate the exit code from the spawn process + waitForProcess phand diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -8,11 +8,11 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Version -import HSE.All import Timing import Paths_hlint import HsColour import EmbedData +import qualified GHC.Util as GHC writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO () @@ -28,7 +28,7 @@ where generateIds :: [String] -> [(String,Int)] -- sorted by name generateIds = map (NE.head &&& length) . NE.group -- must be already sorted - files = generateIds $ sort $ map (srcSpanFilename . ideaSpan) ideas + files = generateIds $ sort $ map (GHC.srcSpanFilename . ideaSpan) ideas hints = generateIds $ map hintName $ sortOn (negate . fromEnum . ideaSeverity &&& hintName) ideas hintName x = show (ideaSeverity x) ++ ": " ++ ideaHint x @@ -41,10 +41,10 @@ ("HINTS",list "hint" hints),("FILES",list "file" files)] content = concatMap (\i -> writeIdea (getClass i) i) ideas - getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcSpanFilename $ ideaSpan i) + getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (GHC.srcSpanFilename $ ideaSpan i) where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs - list mode = zipWith f [0..] + list mode = zipWithFrom f 0 where f i (name,n) = "
  • " ++ escapeHTML name ++ " (" ++ show n ++ ")
    • " @@ -54,7 +54,7 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} = ["
    " - ,escapeHTML (showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "
    " + ,escapeHTML (GHC.showSrcSpan' ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "
    " ,"Found
    " ,hsColourHTML ideaFrom] ++ (case ideaTo of diff --git a/src/Test/All.hs b/src/Test/All.hs --- a/src/Test/All.hs +++ b/src/Test/All.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Test.All(test) where @@ -8,6 +8,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.Char +import Data.Either.Extra import Data.List import System.Directory import System.FilePath @@ -17,27 +18,29 @@ import Config.Type import Config.Read import CmdLine -import HSE.All +import Refact import Hint.All import Test.Util import Test.InputOutput import Test.Annotations import Test.Translate import System.IO.Extra +import GHC.Util.Outputable test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int test CmdTest{..} main dataDir files = do + rpath <- refactorPath (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor) + (failures, ideas) <- withBuffering stdout NoBuffering $ withTests $ do hasSrc <- liftIO $ doesFileExist "hlint.cabal" - useSrc <- return $ hasSrc && null files - testFiles <- if files /= [] then return files else do + let useSrc = hasSrc && null files + testFiles <- if files /= [] then pure files else do xs <- liftIO $ getDirectoryContents dataDir - return [dataDir x | x <- xs, takeExtension x `elem` [".hs",".yml",".yaml"] - , not $ "HLint_" `isPrefixOf` takeBaseName x] + pure [dataDir x | x <- xs, takeExtension x `elem` [".yml",".yaml"]] testFiles <- liftIO $ forM testFiles $ \file -> do hints <- readFilesConfig [(file, Nothing)] - return (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints)) + pure (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints)) let wrap msg act = do liftIO $ putStr (msg ++ " "); act; liftIO $ putStrLn "" liftIO $ putStrLn "Testing" @@ -46,11 +49,13 @@ config <- liftIO $ readFilesConfig [(".hlint.yaml",Nothing)] forM_ builtinHints $ \(name,_) -> do progress - testAnnotations (Builtin name : if name == "Restrict" then config else []) $ "src/Hint" name <.> "hs" + testAnnotations (Builtin name : if name == "Restrict" then config else []) + ("src/Hint" name <.> "hs") + (eitherToMaybe rpath) when useSrc $ wrap "Input/outputs" $ testInputOutput main wrap "Hint names" $ mapM_ (\x -> do progress; testNames $ snd x) testFiles - wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file + wrap "Hint annotations" $ forM_ testFiles $ \(file,h) -> do progress; testAnnotations h file (eitherToMaybe rpath) let hs = [h | (file, h) <- testFiles, takeFileName file /= "Test.hs"] when cmdTypeCheck $ wrap "Hint typechecking" $ progress >> testTypeCheck cmdDataDir cmdTempDir hs @@ -60,7 +65,10 @@ when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" getIdeas whenLoud $ mapM_ print ideas - return failures + case rpath of + Left refactorNotFound -> putStrLn $ unlines [refactorNotFound, "Refactoring tests skipped"] + _ -> pure () + pure failures --------------------------------------------------------------------- @@ -69,7 +77,7 @@ -- Check all hints in the standard config files get sensible names testNames :: [Setting] -> Test () testNames hints = sequence_ - [ failed ["No name for the hint " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS] + [ failed ["No name for the hint " ++ unsafePrettyPrint hintRuleLHS ++ " ==> " ++ unsafePrettyPrint hintRuleRHS] | SettingMatchExp x@HintRule{..} <- hints, hintRuleName == defaultHintName] diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs --- a/src/Test/Annotations.hs +++ b/src/Test/Annotations.hs @@ -4,48 +4,58 @@ module Test.Annotations(testAnnotations) where import Control.Exception.Extra -import Data.Tuple.Extra +import Control.Monad +import Control.Monad.IO.Class import Data.Char import Data.Either.Extra +import Data.Function +import Data.Functor import Data.List.Extra import Data.Maybe -import Control.Monad -import System.FilePath -import Control.Monad.IO.Class -import Data.Function +import Data.Tuple.Extra import Data.Yaml +import System.Exit +import System.FilePath +import System.IO.Extra +import HSE.All import qualified Data.ByteString.Char8 as BS import Config.Type import Idea import Apply -import HSE.All +import Refact import Test.Util -import Data.Functor import Prelude import Config.Yaml +import GHC.Util.Outputable +import FastString +import qualified GHC.Util as GHC +import qualified SrcLoc as GHC + -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs -data TestCase = TestCase SrcLoc String (Maybe String) [Setting] deriving (Show) +data TestCase = TestCase GHC.SrcLoc Refactor String (Maybe String) [Setting] deriving (Show) -testAnnotations :: [Setting] -> FilePath -> Test () -testAnnotations setting file = do +data Refactor = TestRefactor | SkipRefactor deriving (Eq, Show) + +testAnnotations :: [Setting] -> FilePath -> Maybe FilePath -> Test () +testAnnotations setting file rpath = do tests <- liftIO $ parseTestFile file mapM_ f tests where - f (TestCase loc inp out additionalSettings) = do + f (TestCase loc refact inp out additionalSettings) = do ideas <- liftIO $ try_ $ do res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp evaluate $ length $ show res - return res + pure res -- the hints from data/Test.hs are really fake hints we don't actually deploy -- so don't record them when (takeFileName file /= "Test.hs") $ - either (const $ return ()) addIdeas ideas + either (const $ pure ()) addIdeas ideas let good = case (out, ideas) of (Nothing, Right []) -> True @@ -54,19 +64,36 @@ let bad = [failed $ ["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)" - ,"SRC: " ++ showSrcLoc loc + ,"SRC: " ++ unsafePrettyPrint loc ,"INPUT: " ++ inp] ++ - map ("OUTPUT: " ++) (either (return . show) (map show) ideas) ++ + map ("OUTPUT: " ++) (either (pure . show) (map show) ideas) ++ ["WANTED: " ++ fromMaybe "" out] | not good] ++ [failed ["TEST FAILURE (BAD LOCATION)" - ,"SRC: " ++ showSrcLoc loc + ,"SRC: " ++ unsafePrettyPrint loc ,"INPUT: " ++ inp ,"OUTPUT: " ++ show i] - | i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0] - if null bad then passed else sequence_ bad + | i@Idea{..} <- fromRight [] ideas, let GHC.SrcLoc{..} = GHC.srcSpanStart ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0] + -- TODO: shouldn't these checks be == -1 instead? + -- Skip refactoring test if the hlint test failed, or if the + -- test is annotated with @NoRefactor. + let skipRefactor = notNull bad || refact == SkipRefactor + badRefactor <- if skipRefactor then pure [] else liftIO $ do + refactorErr <- case ideas of + Right [] -> testRefactor rpath Nothing inp + Right [idea] -> testRefactor rpath (Just idea) inp + -- Skip refactoring test if there are multiple hints + _ -> pure [] + pure $ [failed $ + ["TEST FAILURE (BAD REFACTORING)" + ,"SRC: " ++ unsafePrettyPrint loc + ,"INPUT: " ++ inp] ++ refactorErr + | notNull refactorErr] + + if null bad && null badRefactor then passed else sequence_ (bad ++ badRefactor) + match "???" _ = True match (word1 -> ("@Message",msg)) i = ideaHint i == msg match (word1 -> ("@Note",note)) i = map show (ideaNote i) == [note] @@ -81,7 +108,7 @@ parseTestFile :: FilePath -> IO [TestCase] parseTestFile file = -- we remove all leading # symbols since Yaml only lets us do comments that way - f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file + f Nothing TestRefactor . zipFrom 1 . map (dropPrefix "# ") . lines <$> readFile file where open :: String -> Maybe [Setting] open line @@ -96,20 +123,60 @@ shut :: String -> Bool shut = isPrefixOf "" - f :: Maybe [Setting] -> [(Int, String)] -> [TestCase] - f Nothing ((i,x):xs) = f (open x) xs - f (Just s) ((i,x):xs) - | shut x = f Nothing xs - | null x || "-- " `isPrefixOf` x = f (Just s) xs - | "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) $ (i,init x++"\n"++y):ys - | otherwise = parseTest file i x s : f (Just s) xs - f _ [] = [] + f :: Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase] + f Nothing _ ((i,x):xs) = f (open x) TestRefactor xs + f (Just s) refact ((i,x):xs) + | shut x = f Nothing TestRefactor xs + | Just (x',_) <- stripInfix "@NoRefactor" x = + f (Just s) SkipRefactor ((i, trimEnd x' ++ ['\\' | "\\" `isSuffixOf` x]) : xs) + | null x || "-- " `isPrefixOf` x = f (Just s) refact xs + | "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) refact $ (i,init x++"\n"++y):ys + | otherwise = parseTest refact file i x s : f (Just s) TestRefactor xs + f _ _ [] = [] -parseTest :: String -> Int -> String -> [Setting] -> TestCase -parseTest file i x = uncurry (TestCase (SrcLoc file i 0)) $ f x +parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase +parseTest refact file i x = uncurry (TestCase (GHC.mkSrcLoc (mkFastString file) i 0) refact) $ f x where f x | Just x <- stripPrefix "" x = first ("--"++) $ f x - f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ dropWhile isSpace xs) + f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ trimStart xs) f (x:xs) = first (x:) $ f xs f [] = ([], Nothing) + + +-- Returns an empty list if the refactoring test passes, otherwise +-- returns error messages. +testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String] +-- Skip refactoring test if the refactor binary is not found. +testRefactor Nothing _ _ = pure [] +-- Skip refactoring test if the hint has no suggestion (i.e., a parse error). +testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure [] +testRefactor (Just rpath) midea inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do + -- Note that we test the refactoring even if there are no suggestions, + -- as an extra test of apply-refact, on which we rely. + -- See https://github.com/ndmitchell/hlint/issues/958 for a discussion. + let refacts = map (show &&& ideaRefactoring) (maybeToList midea) + -- Ignores spaces and semicolons since apply-refact may change them. + process = filter (\c -> not (isSpace c) && c /= ';') + matched expected g actual = process expected `g` process actual + x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y + writeFile tempInp inp + writeFile tempHints (show refacts) + exitCode <- runRefactoring rpath tempInp tempHints "--inplace" + refactored <- readFile tempInp + pure $ case exitCode of + ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec] + ExitSuccess -> case fmap ideaTo midea of + -- No hints. Refactoring should be a no-op. + Nothing | not (matched inp (==) refactored) -> + ["Expected refactor output: " ++ inp, "Actual: " ++ refactored] + -- The hint's suggested replacement is @Just ""@, which means the hint + -- suggests removing something from the input. The refactoring output + -- should be a proper subsequence of the input. + Just (Just "") | not (matched refactored isProperSubsequenceOf inp) -> + ["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored] + -- The hint has a suggested replacement. The suggested replacement + -- should be a substring of the refactoring output. + Just (Just to) | not (matched to isInfixOf refactored) -> + ["Refactor output is expected to contain: " ++ to, "Actual: " ++ refactored] + _ -> [] diff --git a/src/Test/InputOutput.hs b/src/Test/InputOutput.hs --- a/src/Test/InputOutput.hs +++ b/src/Test/InputOutput.hs @@ -24,10 +24,10 @@ testInputOutput :: ([String] -> IO ()) -> Test () testInputOutput main = do xs <- liftIO $ getDirectoryContents "tests" - xs <- return $ filter ((==) ".test" . takeExtension) xs + xs <- pure $ filter ((==) ".test" . takeExtension) xs forM_ xs $ \file -> do ios <- liftIO $ parseInputOutputs <$> readFile ("tests" file) - forM_ (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do + forM_ (zipFrom 1 ios) $ \(i,io@InputOutput{..}) -> do progress liftIO $ forM_ files $ \(name,contents) -> do createDirectoryIfMissing True $ takeDirectory name @@ -71,7 +71,7 @@ handle (\(e::ExitCode) -> writeIORef code e) $ bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run code <- liftIO $ readIORef code - (want,got) <- return $ matchStarStar (lines output) got + (want,got) <- pure $ matchStarStar (lines output) got if maybe False (/= code) exit then failed @@ -96,7 +96,12 @@ -- | First string may have stars in it (the want) matchStar :: String -> String -> Bool matchStar ('*':xs) ys = any (matchStar xs) $ tails ys -matchStar (x:xs) (y:ys) = x == y && matchStar xs ys +matchStar ('/':x:xs) ('\\':'\\':ys) | x /= '/' = matchStar (x:xs) ys -- JSON escaped newlines +matchStar (x:xs) (y:ys) = eq x y && matchStar xs ys + where + -- allow path differences between Windows and Linux + eq '/' y = isPathSeparator y + eq x y = x == y matchStar [] [] = True matchStar _ _ = False diff --git a/src/Test/Proof.hs b/src/Test/Proof.hs --- a/src/Test/Proof.hs +++ b/src/Test/Proof.hs @@ -1,12 +1,21 @@ -{-# LANGUAGE RecordWildCards, PatternGuards, FlexibleContexts #-} -- | Check the coverage of the hints given a list of Isabelle theorems module Test.Proof(proof) where +import Config.Type +import Control.Exception.Extra + +proof :: [FilePath] -> [Setting] -> FilePath -> IO () +proof _ _ _ = errorIO "Test.Proof is disabled." + +{- + import Data.Tuple.Extra import Control.Applicative import Control.Monad import Control.Monad.Trans.State +import Language.Haskell.Exts.Util(paren, FreeVars, freeVars) +import qualified Data.Set as Set import Data.Char import Data.List.Extra import Data.Maybe @@ -143,8 +152,8 @@ f (ValidInstance cls var) x = evalState (transformM g x) True where g v@Var{} | v ~= var = do b <- get; put False - return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v - g v = return v :: State Bool Exp_ + pure $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v + g v = pure v :: State Bool Exp_ f _ x = x relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\ " ++ b @@ -184,3 +193,7 @@ pat x = prettyPrint x fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x + +vars :: FreeVars a => a -> [String] +vars = Set.toList . Set.map prettyPrint . freeVars +-} diff --git a/src/Test/Translate.hs b/src/Test/Translate.hs --- a/src/Test/Translate.hs +++ b/src/Test/Translate.hs @@ -2,6 +2,19 @@ -- | Translate the hints to Haskell and run with GHC. module Test.Translate(testTypeCheck, testQuickCheck) where +import Config.Type +import Control.Exception.Extra +import Control.Monad.IO.Class +import Test.Util + +testTypeCheck :: FilePath -> FilePath -> [[Setting]] -> Test () +testTypeCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled." + +-- | Given a set of hints, do all the HintRule hints satisfy QuickCheck +testQuickCheck :: FilePath -> FilePath -> [[Setting]] -> Test () +testQuickCheck _ _ _ = liftIO $ errorIO "Test.Translate is disabled." + +{- import Control.Monad import Control.Monad.IO.Class import Data.List.Extra @@ -10,6 +23,8 @@ import System.Process import System.Exit import System.FilePath +import Language.Haskell.Exts.Util(FreeVars, freeVars) +import qualified Data.Set as Set import Config.Type import HSE.All @@ -19,10 +34,10 @@ runMains :: FilePath -> FilePath -> [String] -> Test () runMains datadir tmpdir xs = do res <- liftIO $ (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do - ms <- forM (zip [1..] xs) $ \(i,x) -> do + ms <- forM (zipFrom 1 xs) $ \(i,x) -> do let m = "I" ++ show i writeFile (dir m <.> "hs") $ replace "module Main" ("module " ++ m) x - return m + pure m writeFile (dir "Main.hs") $ unlines $ ["import qualified " ++ m | m <- ms] ++ ["main = do"] ++ @@ -46,13 +61,15 @@ ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}" ,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}" ,"module Main(main) where"] ++ - concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++ + -- concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++ f xs + {- -- Hack around haskell98 not being compatible with base anymore hackImport i@ImportDecl{importAs=Just a,importModule=b} | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a} hackImport i = i + -} --------------------------------------------------------------------- @@ -61,10 +78,10 @@ toTypeCheck :: [HintRule] -> [String] toTypeCheck hints = ["import HLint_TypeCheck hiding(main)" - ,"main = return ()"] ++ + ,"main = pure ()"] ++ ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++ prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing) - | (i, HintRule _ _ _ lhs rhs side _notes _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side) + | (i, HintRule _ _ lhs rhs side _notes _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 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 +105,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 _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side) + | (i, HintRule _ _ lhs rhs side note _ghcScope _ghcLhs _ghcRhs _ghcSide) <- zipFrom 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) @@ -104,3 +121,7 @@ isRemovesError :: Note -> Bool isRemovesError RemovesError{} = True isRemovesError _ = False + +vars :: FreeVars a => a -> [String] +vars = Set.toList . Set.map prettyPrint . freeVars +-} diff --git a/src/Test/Util.hs b/src/Test/Util.hs --- a/src/Test/Util.hs +++ b/src/Test/Util.hs @@ -2,7 +2,7 @@ module Test.Util( Test, withTests, - tested, passed, failed, progress, + passed, failed, progress, addIdeas, getIdeas ) where @@ -32,7 +32,7 @@ putStrLn $ if failures == 0 then "Tests passed (" ++ show total ++ ")" else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")" - return (failures, res) + pure (failures, res) addIdeas :: [Idea] -> Test () addIdeas xs = do @@ -57,6 +57,3 @@ unless (null xs) $ liftIO $ putStrLn $ unlines $ "" : xs ref <- Test ask liftIO $ modifyIORef' ref $ \s -> s{total=total s+1, failures=failures s+1} - -tested :: Bool -> Test () -tested b = if b then passed else failed [] diff --git a/src/Timing.hs b/src/Timing.hs --- a/src/Timing.hs +++ b/src/Timing.hs @@ -41,9 +41,9 @@ let quiet = c == "Hint" unless quiet $ whenLoud $ putStr $ "Performing " ++ c ++ " of " ++ i ++ "... " (time, x) <- duration x - atomicModifyIORef' timings $ \mp -> (Map.insertWith (+) (c, i) time mp, ()) + atomicModifyIORef'_ timings $ Map.insertWith (+) (c, i) time unless quiet $ whenLoud $ putStrLn $ "took " ++ showDuration time - return x + pure x startTimings :: IO () startTimings = do diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,22 +1,18 @@ {-# LANGUAGE ExistentialQuantification, Rank2Types #-} module Util( - parseExtensions, - configExtensions, forceList, gzip, universeParentBi, exitMessage, exitMessageImpure, getContentsUTF8 ) where -import Data.List import System.Exit import System.IO import System.IO.Unsafe import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.Operations -import Language.Haskell.Exts.Extension --------------------------------------------------------------------- @@ -68,29 +64,3 @@ universeParentBi :: Biplate a b => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi - - ---------------------------------------------------------------------- --- LANGUAGE.HASKELL.EXTS.EXTENSION - --- | 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 = reallyBadExtensions ++ - [Arrows -- steals proc - ,UnboxedTuples, UnboxedSums -- breaks (#) lens operator - ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break - ,DoRec, RecursiveDo -- breaks rec - ,TypeApplications -- HSE fails on @ patterns - ] - -reallyBadExtensions = - [TransformListComp -- steals the group keyword - ,XmlSyntax, RegularPatterns -- steals a-b and < operators - ]