{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Internal.FixWarnings
  ( fixWarning
  , fixRedundancyWarning
  , RedundancyWarn(..)
  ) where

import           Control.Applicative ((<|>))
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.State
import           Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS
import           Data.Char (isSpace)
import           Data.Maybe (isJust)
import           Data.Monoid (Alt(..))
import qualified Data.Map.Strict as M
import qualified System.Directory as Dir
import qualified Text.ParserCombinators.ReadP as P

import qualified Internal.GhcFacade as Ghc
import           Internal.Types

-- | Fixes applicable warning
fixWarning :: ModuleFile -> WarningsWithModDate -> IO WarningsWithModDate
fixWarning :: String -> WarningsWithModDate -> IO WarningsWithModDate
fixWarning String
modFile
           warns :: WarningsWithModDate
warns@MkWarningsWithModDate
             { lastUpdated :: WarningsWithModDate -> UTCTime
lastUpdated = UTCTime
modifiedAt
             , warningsMap :: WarningsWithModDate -> MonoidMap SrcSpanKey (Set Warning)
warningsMap = MonoidMap Map SrcSpanKey (Set Warning)
warnMap
             } = do

  UTCTime
lastModification <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
Dir.getModificationTime String
modFile

  -- Do not attempt to edit if file has been touched since last reload
  if UTCTime
lastModification UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= UTCTime
modifiedAt
  then do
    String -> IO ()
putStrLn
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
modFile
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' has been modified since last compiled. Reload and try again."
    WarningsWithModDate -> IO WarningsWithModDate
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WarningsWithModDate
warns

  else do
    [ByteString]
curSrcLines <- IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> IO [ByteString])
-> (IO ByteString -> IO [ByteString])
-> IO ByteString
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [ByteString]
BS.lines (IO ByteString -> IO [ByteString])
-> IO ByteString -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
modFile

    -- State is used to keep the contents of the source file in memory while
    -- warnings for the file are fixed.
    ([(SrcSpanKey, Set Warning)]
pairs, [ByteString]
newFileContents) <- (StateT [ByteString] IO [(SrcSpanKey, Set Warning)]
-> [ByteString] -> IO ([(SrcSpanKey, Set Warning)], [ByteString])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` [ByteString]
curSrcLines)
             (StateT [ByteString] IO [(SrcSpanKey, Set Warning)]
 -> IO ([(SrcSpanKey, Set Warning)], [ByteString]))
-> (((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
    -> StateT [ByteString] IO [(SrcSpanKey, Set Warning)])
-> ((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
-> IO ([(SrcSpanKey, Set Warning)], [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
 -> [(SrcSpanKey, Set Warning)]
 -> StateT [ByteString] IO [(SrcSpanKey, Set Warning)])
-> [(SrcSpanKey, Set Warning)]
-> ((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
-> StateT [ByteString] IO [(SrcSpanKey, Set Warning)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
-> [(SrcSpanKey, Set Warning)]
-> StateT [ByteString] IO [(SrcSpanKey, Set Warning)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([(SrcSpanKey, Set Warning)] -> [(SrcSpanKey, Set Warning)]
forall a. [a] -> [a]
reverse ([(SrcSpanKey, Set Warning)] -> [(SrcSpanKey, Set Warning)])
-> [(SrcSpanKey, Set Warning)] -> [(SrcSpanKey, Set Warning)]
forall a b. (a -> b) -> a -> b
$ Map SrcSpanKey (Set Warning) -> [(SrcSpanKey, Set Warning)]
forall k a. Map k a -> [(k, a)]
M.toList Map SrcSpanKey (Set Warning)
warnMap) (((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
 -> IO ([(SrcSpanKey, Set Warning)], [ByteString]))
-> ((SrcSpanKey, Set Warning) -> StateT [ByteString] IO Bool)
-> IO ([(SrcSpanKey, Set Warning)], [ByteString])
forall a b. (a -> b) -> a -> b
$ \case
      ((RealSrcLoc
start, RealSrcLoc
_), Set Warning
warnSet)
        | Alt (Just RedundancyWarn
reWarn) -- Take the first redundancy warning parsed
            <- (Warning -> Alt Maybe RedundancyWarn)
-> Set Warning -> Alt Maybe RedundancyWarn
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe RedundancyWarn -> Alt Maybe RedundancyWarn
forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt (Maybe RedundancyWarn -> Alt Maybe RedundancyWarn)
-> (Warning -> Maybe RedundancyWarn)
-> Warning
-> Alt Maybe RedundancyWarn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> Maybe RedundancyWarn
parseRedundancyWarn) Set Warning
warnSet
        -> do
          [ByteString]
srcLines <- StateT [ByteString] IO [ByteString]
forall (m :: * -> *) s. Monad m => StateT s m s
get

          -- attempt to fix the warning
          let startLine :: Int
startLine = RealSrcLoc -> Int
Ghc.srcLocLine RealSrcLoc
start
              mNewSrcLines :: Maybe [ByteString]
mNewSrcLines =
                Int -> RedundancyWarn -> [ByteString] -> Maybe [ByteString]
fixRedundancyWarning Int
startLine RedundancyWarn
reWarn [ByteString]
srcLines

          case Maybe [ByteString]
mNewSrcLines of
            Maybe [ByteString]
Nothing -> Bool -> StateT [ByteString] IO Bool
forall a. a -> StateT [ByteString] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

            Just [ByteString]
newSrcLines -> do
              [ByteString] -> StateT [ByteString] IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [ByteString]
newSrcLines
              Bool -> StateT [ByteString] IO Bool
forall a. a -> StateT [ByteString] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

      (SrcSpanKey, Set Warning)
_ -> Bool -> StateT [ByteString] IO Bool
forall a. a -> StateT [ByteString] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(SrcSpanKey, Set Warning)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SrcSpanKey, Set Warning)]
pairs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Map SrcSpanKey (Set Warning) -> Int
forall a. Map SrcSpanKey a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map SrcSpanKey (Set Warning)
warnMap) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- write the changes to the file
      String -> ByteString -> IO ()
BS.writeFile String
modFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.unlines [ByteString]
newFileContents
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
modFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' has been edited"

    WarningsWithModDate -> IO WarningsWithModDate
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MkWarningsWithModDate
           { lastUpdated :: UTCTime
lastUpdated = UTCTime
lastModification
           , warningsMap :: MonoidMap SrcSpanKey (Set Warning)
warningsMap = Map SrcSpanKey (Set Warning) -> MonoidMap SrcSpanKey (Set Warning)
forall k a. Map k a -> MonoidMap k a
MonoidMap (Map SrcSpanKey (Set Warning)
 -> MonoidMap SrcSpanKey (Set Warning))
-> Map SrcSpanKey (Set Warning)
-> MonoidMap SrcSpanKey (Set Warning)
forall a b. (a -> b) -> a -> b
$ [(SrcSpanKey, Set Warning)] -> Map SrcSpanKey (Set Warning)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(SrcSpanKey, Set Warning)]
pairs
           }

-- | Attempt to fix redundant import warning.
-- Returns 'Nothing' if incapable of fixing.
fixRedundancyWarning :: Int
                     -> RedundancyWarn
                     -> [BS.ByteString]
                     -> Maybe [BS.ByteString]
fixRedundancyWarning :: Int -> RedundancyWarn -> [ByteString] -> Maybe [ByteString]
fixRedundancyWarning Int
startLine RedundancyWarn
warn [ByteString]
srcLines = do
  -- The span for redundant errors is only ever a single line. This means we
  -- must search for the end of the import statement. If this a warning about a
  -- single import thing, the span line may not encompass the start of the
  -- import statement so we must search for that as well.

  ([ByteString]
before, ByteString
stmt : [ByteString]
after) <- ([ByteString], [ByteString]) -> Maybe ([ByteString], [ByteString])
forall a. a -> Maybe a
Just (([ByteString], [ByteString])
 -> Maybe ([ByteString], [ByteString]))
-> ([ByteString], [ByteString])
-> Maybe ([ByteString], [ByteString])
forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> ([ByteString], [ByteString])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
startLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [ByteString]
srcLines

  let isStart :: ByteString -> Bool
isStart ByteString
bs = ByteString
"import" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString -> ByteString
BS.dropSpace ByteString
bs

  -- If the first line is not the start of the import declaration, search for
  -- it in the preceding lines.
  ([ByteString]
before', [ByteString]
stmt') <-
    if ByteString -> Bool
isStart ByteString
stmt
       then ([ByteString], [ByteString]) -> Maybe ([ByteString], [ByteString])
forall a. a -> Maybe a
Just ([ByteString]
before, [ByteString
stmt])
       else do
         ([ByteString]
inS, ByteString
st : [ByteString]
rs) <- ([ByteString], [ByteString]) -> Maybe ([ByteString], [ByteString])
forall a. a -> Maybe a
Just (([ByteString], [ByteString])
 -> Maybe ([ByteString], [ByteString]))
-> ([ByteString] -> ([ByteString], [ByteString]))
-> [ByteString]
-> Maybe ([ByteString], [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool)
-> [ByteString] -> ([ByteString], [ByteString])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ByteString -> Bool
isStart ([ByteString] -> Maybe ([ByteString], [ByteString]))
-> [ByteString] -> Maybe ([ByteString], [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString
stmt ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
before
         ([ByteString], [ByteString]) -> Maybe ([ByteString], [ByteString])
forall a. a -> Maybe a
Just ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rs, ByteString
st ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
inS)

  let ([ByteString]
stmt'', [ByteString]
after') = [ByteString] -> ([ByteString], [ByteString])
splitAtImportEnd ([ByteString] -> ([ByteString], [ByteString]))
-> [ByteString] -> ([ByteString], [ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString]
stmt' [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
after

      hasExplicitList :: Bool
hasExplicitList
        -- Check the next line to see if it contains an explicit import list
        | ByteString
a : [ByteString]
_ <- [ByteString]
after
        , ByteString -> Int
BS.length ((Char -> Bool) -> ByteString -> ByteString
BS.takeWhile Char -> Bool
isSpace ByteString
a)
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
BS.length ((Char -> Bool) -> ByteString -> ByteString
BS.takeWhile Char -> Bool
isSpace ByteString
stmt)
        , Int -> ByteString -> ByteString
BS.take Int
1 (ByteString -> ByteString
BS.dropSpace ByteString
a) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"("
          = Bool
True
        | Bool
otherwise = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Char -> ByteString -> Maybe Int
BS.elemIndex Char
'(' ByteString
stmt)

  case RedundancyWarn
warn of
    RedundancyWarn
WholeModule
      | Bool
hasExplicitList -> [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just ([ByteString] -> Maybe [ByteString])
-> [ByteString] -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
before [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
after'
      | Bool
otherwise       -> [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just ([ByteString] -> Maybe [ByteString])
-> [ByteString] -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
before [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
after

    IndividualThings [String]
things ->
      ([ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
after') ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString]
before' [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<>) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines (ByteString -> [ByteString])
-> Maybe ByteString -> Maybe [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (ByteString -> String -> Maybe ByteString)
-> ByteString -> [String] -> Maybe ByteString
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ByteString -> String -> Maybe ByteString
fixRedundantThing
              ([ByteString] -> ByteString
BS.unlines [ByteString]
stmt'')
              [String]
things

-- | Splits at the end of an import with an explicit list by counting the
-- number of opening and closing parens. If the main parens is closed, then
-- that marks the end of the import.
splitAtImportEnd :: [BS.ByteString] -> ([BS.ByteString], [BS.ByteString])
splitAtImportEnd :: [ByteString] -> ([ByteString], [ByteString])
splitAtImportEnd [ByteString]
ls = ([ByteString] -> [ByteString])
-> ([ByteString], [ByteString]) -> ([ByteString], [ByteString])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (([ByteString], [ByteString]) -> ([ByteString], [ByteString]))
-> ([ByteString], [ByteString]) -> ([ByteString], [ByteString])
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> ([ByteString], [ByteString])
-> ([ByteString], [ByteString])
go Int
0 Int
0 ([], [ByteString]
ls) where
  go :: Int
-> Int
-> ([ByteString], [ByteString])
-> ([ByteString], [ByteString])
go Int
o Int
c ([ByteString], [ByteString])
acc
    | Int
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 , Int
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c
    = ([ByteString], [ByteString])
acc
  go Int
_ Int
_ acc :: ([ByteString], [ByteString])
acc@([ByteString]
_, []) = ([ByteString], [ByteString])
acc -- shouldn't happen
  go Int
o Int
c ([ByteString]
stmt, ByteString
r:[ByteString]
rest) =
    let addO :: Int
addO = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [Int]
BS.elemIndices Char
'(' ByteString
r
        addC :: Int
addC = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [Int]
BS.elemIndices Char
')' ByteString
r
     in Int
-> Int
-> ([ByteString], [ByteString])
-> ([ByteString], [ByteString])
go (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
addO) (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
addC) (ByteString
r ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
stmt, [ByteString]
rest)

-- | Removes a particular thing from an import list without disrupting the
-- formatting. Returns 'Nothing' if the thing doesn't exist or appears more
-- than once.
--
-- Edges cases not handled:
-- - Comments interspersed in the statement that mention the thing
-- - Semicolon layout
fixRedundantThing :: BS.ByteString -> String -> Maybe BS.ByteString
fixRedundantThing :: ByteString -> String -> Maybe ByteString
fixRedundantThing ByteString
stmt String
thing
  -- Bail if there is more than one valid candidate
  | [(ByteString
start, ByteString
match)] <- ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString, ByteString) -> Bool
isValidCandidate ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
findCandidates ByteString
stmt

    -- 1) remove the needle
    -- 2) remove enclosing parens
    -- 3) remove stuff to the right (..) etc.
    -- 4) if there's a comma to the right, remove it as well

    -- preserve the whitespace immediately after the ',' or '('
  , let start' :: ByteString
start' = let (ByteString
s, ByteString
e) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.breakEnd (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',', Char
'(']) ByteString
start
                  in ByteString
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> ByteString -> ByteString
BS.takeWhile Char -> Bool
isSpace ByteString
e

        end :: ByteString
end = Int -> ByteString -> ByteString
BS.drop Int
thingLen ByteString
match
  = do
    (ByteString
start'', ByteString
end') <- (ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (ByteString, a) -> f (ByteString, b)
traverse ByteString -> Maybe ByteString
removeAssociatedIds
                     ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> (ByteString, ByteString)
removeEnclosingParens ByteString
start' ByteString
end
    ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
end' Maybe (Char, ByteString)
-> ((Char, ByteString) -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Don't do this if the removed thing was an associated constructor
      (Char
',', ByteString
end'')
        | Just (ByteString
_, Char
e) <- ByteString -> Maybe (ByteString, Char)
BS.unsnoc (ByteString -> Maybe (ByteString, Char))
-> ByteString -> Maybe (ByteString, Char)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.dropWhileEnd Char -> Bool
isSpace ByteString
start''
        , Char
e Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',', Char
'('] -- Check if the target thing was not an associated constructor/method
        -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
start'' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BS.dropSpace ByteString
end''
        | Bool
otherwise -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
start'' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
end'
      -- If bound on the right by ')', remove the suffix containing ',' from start
      (Char
')', ByteString
_) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
startTrim ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
end'
        where
          startTrim :: ByteString
startTrim = (Char -> Bool) -> ByteString -> ByteString
BS.dropWhileEnd Char -> Bool
isSpace ByteString
start''
      (Char, ByteString)
_ -> Maybe ByteString
forall a. Maybe a
Nothing

  | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing
  where
    thingBS :: ByteString
thingBS = String -> ByteString
BS.pack String
thing
    thingLen :: Int
thingLen = ByteString -> Int
BS.length ByteString
thingBS

    -- A list of substring matches where each element is a pair of the prefix
    -- with the match and remaining suffix.
    findCandidates :: ByteString -> [(ByteString, ByteString)]
findCandidates ByteString
"" = []
    findCandidates ByteString
inp =
    -- first isolate the portion that is within an open parens, otherwise
    -- if the module name is the same as the target then the search will fail.
      let (ByteString
beforeParen, ByteString
inp') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
inp
          (ByteString
pre, ByteString
match) = ByteString -> ByteString -> (ByteString, ByteString)
BS.breakSubstring ByteString
thingBS ByteString
inp'
       in (ByteString
beforeParen ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pre, ByteString
match) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:
            ( (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((ByteString
beforeParen ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pre ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
thingBS) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)
            ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(ByteString, ByteString)]
findCandidates (Int -> ByteString -> ByteString
BS.drop Int
thingLen ByteString
match)
            )

    -- Test if a match pair is valid by checking that the match is not a
    -- substring of a different identifier
    isValidCandidate :: (ByteString, ByteString) -> Bool
isValidCandidate (ByteString
start, ByteString
match) =
      Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
match)
      Bool -> Bool -> Bool
&& ByteString -> Bool
isSeparator (Int -> ByteString -> ByteString
BS.drop Int
thingLen ByteString
match)
      Bool -> Bool -> Bool
&& ByteString -> Bool
isCellStart (ByteString -> ByteString
BS.reverse ByteString
start)

    isSeparator :: ByteString -> Bool
isSeparator = (Char -> Bool) -> ByteString -> Bool
headPred ((Char -> Bool) -> ByteString -> Bool)
-> (Char -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',', Char
'(', Char
')']
    isCellStart :: ByteString -> Bool
isCellStart = (Char -> Bool) -> ByteString -> Bool
headPred ((Char -> Bool) -> ByteString -> Bool)
-> (Char -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',', Char
'(']
    headPred :: (Char -> Bool) -> BS.ByteString -> Bool
    headPred :: (Char -> Bool) -> ByteString -> Bool
headPred Char -> Bool
p = Bool
-> ((Char, ByteString) -> Bool) -> Maybe (Char, ByteString) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
p (Char -> Bool)
-> ((Char, ByteString) -> Char) -> (Char, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, ByteString) -> Char
forall a b. (a, b) -> a
fst) (Maybe (Char, ByteString) -> Bool)
-> (ByteString -> Maybe (Char, ByteString)) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Char, ByteString)
BS.uncons

    -- If dealing with an operator, there will be enclosing parens with possible
    -- whitespace surrounding the operator.
    removeEnclosingParens :: ByteString -> ByteString -> (ByteString, ByteString)
removeEnclosingParens ByteString
startBS (ByteString -> ByteString
BS.dropSpace -> ByteString
endBS)
      | Just (Char
')', ByteString
end') <- ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
endBS
      , Just (ByteString
start', Char
'(') <- ByteString -> Maybe (ByteString, Char)
BS.unsnoc (ByteString -> Maybe (ByteString, Char))
-> ByteString -> Maybe (ByteString, Char)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.dropWhileEnd Char -> Bool
isSpace ByteString
startBS
      -- recurse because it could be an associated constructor that is an operator,
      -- i.e. NonEmpty((:|))
      = ByteString -> ByteString -> (ByteString, ByteString)
removeEnclosingParens ByteString
start' ByteString
end'
      | Bool
otherwise = (ByteString
startBS, ByteString
endBS)

-- | Remove list of associated constructors of a type or methods of a class
-- and any space up until the next cell terminator.
removeAssociatedIds :: BS.ByteString -> Maybe BS.ByteString
removeAssociatedIds :: ByteString -> Maybe ByteString
removeAssociatedIds = ByteString -> Maybe ByteString
checkForParens
  where
    checkForParens :: ByteString -> Maybe ByteString
checkForParens ByteString
bs =
      let bs' :: ByteString
bs' = ByteString -> ByteString
BS.dropSpace ByteString
bs
       in case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
bs' of
            Maybe (Char, ByteString)
Nothing -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""
            Just (Char
c, ByteString
r)
              | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' -> Int -> ByteString -> Maybe ByteString
removeParens Int
1 ByteString
r
            Maybe (Char, ByteString)
_ -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs'

    -- counts the depth of nested parens to handle the case of an operator
    -- appearing in the list.
    removeParens :: Int -> BS.ByteString -> Maybe BS.ByteString
    removeParens :: Int -> ByteString -> Maybe ByteString
removeParens Int
0 ByteString
bs = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.dropSpace ByteString
bs
    removeParens !Int
n ByteString
bs =
      let bs' :: ByteString
bs' = (Char -> Bool) -> ByteString -> ByteString
BS.dropWhile (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') ByteString
bs
       in case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
bs' of
            Just (Char
c, ByteString
r)
              | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' -> Int -> ByteString -> Maybe ByteString
removeParens (Int -> Int
forall a. Enum a => a -> a
succ Int
n) ByteString
r
              | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' -> Int -> ByteString -> Maybe ByteString
removeParens (Int -> Int
forall a. Enum a => a -> a
pred Int
n) ByteString
r
            Maybe (Char, ByteString)
_ -> Maybe ByteString
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Parsing
--------------------------------------------------------------------------------

-- | Redundant import warnings
data RedundancyWarn
  = WholeModule
  | IndividualThings [String]
  deriving Int -> RedundancyWarn -> String -> String
[RedundancyWarn] -> String -> String
RedundancyWarn -> String
(Int -> RedundancyWarn -> String -> String)
-> (RedundancyWarn -> String)
-> ([RedundancyWarn] -> String -> String)
-> Show RedundancyWarn
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RedundancyWarn -> String -> String
showsPrec :: Int -> RedundancyWarn -> String -> String
$cshow :: RedundancyWarn -> String
show :: RedundancyWarn -> String
$cshowList :: [RedundancyWarn] -> String -> String
showList :: [RedundancyWarn] -> String -> String
Show

parseRedundancyWarn :: Warning -> Maybe RedundancyWarn
parseRedundancyWarn :: Warning -> Maybe RedundancyWarn
parseRedundancyWarn Warning
warn =
  case ReadP RedundancyWarn -> ReadS RedundancyWarn
forall a. ReadP a -> ReadS a
P.readP_to_S ReadP RedundancyWarn
redundancyWarnParser (Warning -> String
showWarning Warning
warn) of
    [(RedundancyWarn
w, String
"")] -> RedundancyWarn -> Maybe RedundancyWarn
forall a. a -> Maybe a
Just RedundancyWarn
w
    [(RedundancyWarn, String)]
_ -> Maybe RedundancyWarn
forall a. Maybe a
Nothing

redundancyWarnParser :: P.ReadP RedundancyWarn
redundancyWarnParser :: ReadP RedundancyWarn
redundancyWarnParser = do
  String
_ <- String -> ReadP String
P.string String
"The import of ‘"
   ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ReadP String
P.string String
"The qualified import of ‘"

  [String]
inQuotes <-
    ReadP String -> ReadP Char -> ReadP [String]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
P.sepBy1 ((Char -> Bool) -> ReadP String
P.munch1 ((Char -> Bool) -> ReadP String) -> (Char -> Bool) -> ReadP String
forall a b. (a -> b) -> a -> b
$ \Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
',', Char
'’'])
             (Char -> ReadP Char
P.char Char
',' ReadP Char -> ReadP () -> ReadP Char
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
P.skipSpaces)

  Char
_ <- Char -> ReadP Char
P.char Char
'’'

  let terms :: ReadP RedundancyWarn
terms
        = [String] -> RedundancyWarn
IndividualThings [String]
inQuotes
         RedundancyWarn -> ReadP String -> ReadP RedundancyWarn
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( ReadP ()
P.skipSpaces
           ReadP () -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ReadP String
P.string String
"from module ‘"
           ReadP String -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> ReadP String
P.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'’')
           ReadP String -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ReadP String
P.string String
"’ is redundant"
            )

      wholeMod :: ReadP RedundancyWarn
wholeMod = RedundancyWarn
WholeModule
              RedundancyWarn -> ReadP String -> ReadP RedundancyWarn
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ReadP ()
P.skipSpaces ReadP () -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ReadP String
P.string String
"is redundant")

  RedundancyWarn
result <- [ReadP RedundancyWarn] -> ReadP RedundancyWarn
forall a. [ReadP a] -> ReadP a
P.choice [ReadP RedundancyWarn
terms, ReadP RedundancyWarn
wholeMod]

  String
_ <- (Char -> Bool) -> ReadP String
P.munch (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

  RedundancyWarn -> ReadP RedundancyWarn
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedundancyWarn
result