{-# language RecordWildCards #-}
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}

module Weeder.Run ( runWeeder, Weed(..), formatWeed ) where

-- base
import Control.Applicative ( liftA2 )
import Control.Monad ( guard )
import Data.List ( sortOn )
import Data.Foldable ( fold, foldl' )
import Data.Function ( (&) )

-- containers
import Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map

-- ghc
import GHC.Plugins
  ( occNameString
  , unitString
  , moduleUnit
  , moduleName
  , moduleNameString
  )
import GHC.Iface.Ext.Types ( HieFile( hie_asts ), getAsts )
import GHC.Iface.Ext.Utils (generateReferencesMap)

-- parallel
import Control.Parallel (pseq)
import Control.Parallel.Strategies (parMap, rdeepseq)

-- regex-tdfa
import Text.Regex.TDFA ( matchTest )

-- transformers
import Control.Monad.State.Strict ( execState )

-- weeder
import Weeder
import Weeder.Config


data Weed = Weed
  { Weed -> String
weedPackage :: String
  , Weed -> String
weedPath :: FilePath
  , Weed -> Int
weedLine :: Int
  , Weed -> Int
weedCol :: Int
  , Weed -> Declaration
weedDeclaration :: Declaration
  , Weed -> Maybe String
weedPrettyPrintedType :: Maybe String
  }


formatWeed :: Weed -> String
formatWeed :: Weed -> String
formatWeed Weed{Int
String
Maybe String
Declaration
weedPackage :: Weed -> String
weedPath :: Weed -> String
weedLine :: Weed -> Int
weedCol :: Weed -> Int
weedDeclaration :: Weed -> Declaration
weedPrettyPrintedType :: Weed -> Maybe String
weedPackage :: String
weedPath :: String
weedLine :: Int
weedCol :: Int
weedDeclaration :: Declaration
weedPrettyPrintedType :: Maybe String
..} =
  String
weedPackage String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
weedPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
weedLine String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
weedCol String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> case Maybe String
weedPrettyPrintedType of
      Maybe String
Nothing -> OccName -> String
occNameString ( Declaration -> OccName
declOccName Declaration
weedDeclaration )
      Just String
t -> String
"(Instance) :: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
t

-- | Run Weeder on the given .hie files with the given 'Config'.
--
-- Returns a list of 'Weed's that can be displayed using
-- 'formatWeed', and the final 'Analysis'.
runWeeder :: Config -> [HieFile] -> ([Weed], Analysis)
runWeeder :: Config -> [HieFile] -> ([Weed], Analysis)
runWeeder weederConfig :: Config
weederConfig@Config{ [Regex]
rootPatterns :: [Regex]
rootPatterns :: forall a. ConfigType a -> [a]
rootPatterns, Bool
typeClassRoots :: Bool
typeClassRoots :: forall a. ConfigType a -> Bool
typeClassRoots, [InstancePattern Regex]
rootInstances :: [InstancePattern Regex]
rootInstances :: forall a. ConfigType a -> [InstancePattern a]
rootInstances, [Regex]
rootModules :: [Regex]
rootModules :: forall a. ConfigType a -> [a]
rootModules } [HieFile]
hieFiles =
  let 
    asts :: [HieAST Int]
asts = (HieFile -> [HieAST Int]) -> [HieFile] -> [HieAST Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map HiePath (HieAST Int) -> [HieAST Int]
forall k a. Map k a -> [a]
Map.elems (Map HiePath (HieAST Int) -> [HieAST Int])
-> (HieFile -> Map HiePath (HieAST Int)) -> HieFile -> [HieAST Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieASTs Int -> Map HiePath (HieAST Int)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs Int -> Map HiePath (HieAST Int))
-> (HieFile -> HieASTs Int) -> HieFile -> Map HiePath (HieAST Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> HieASTs Int
hie_asts) [HieFile]
hieFiles

    rf :: RefMap Int
rf = [HieAST Int] -> RefMap Int
forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
generateReferencesMap [HieAST Int]
asts

    analyses :: [Analysis]
analyses =
      Strategy Analysis
-> (HieFile -> Analysis) -> [HieFile] -> [Analysis]
forall b a. Strategy b -> (a -> b) -> [a] -> [b]
parMap Strategy Analysis
forall a. NFData a => Strategy a
rdeepseq (\HieFile
hf -> State Analysis () -> Analysis -> Analysis
forall s a. State s a -> s -> s
execState (Config -> HieFile -> State Analysis ()
forall (m :: * -> *).
MonadState Analysis m =>
Config -> HieFile -> m ()
analyseHieFile Config
weederConfig HieFile
hf) Analysis
emptyAnalysis) [HieFile]
hieFiles

    analyseEvidenceUses' :: Analysis -> Analysis
analyseEvidenceUses' = 
      if Bool
typeClassRoots
        then Analysis -> Analysis
forall a. a -> a
id
        else RefMap Int -> Analysis -> Analysis
analyseEvidenceUses RefMap Int
rf

    analysis1 :: Analysis
analysis1 = 
      (Analysis -> Analysis -> Analysis)
-> Analysis -> [Analysis] -> Analysis
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Analysis -> Analysis -> Analysis
forall a. Monoid a => a -> a -> a
mappend Analysis
forall a. Monoid a => a
mempty [Analysis]
analyses

    -- Evaluating 'analysis1' first allows us to begin analysis 
    -- while hieFiles is still being read (since rf depends on all hie files)
    analysis :: Analysis
analysis = Analysis
analysis1 Analysis -> Analysis -> Analysis
forall a b. a -> b -> b
`pseq`
      Analysis -> Analysis
analyseEvidenceUses' Analysis
analysis1

    -- We limit ourselves to outputable declarations only rather than all
    -- declarations in the graph. This has a slight performance benefit,
    -- at the cost of having to assume that a non-outputable declaration
    -- will always either be an implicit root or irrelevant.
    roots :: Set Declaration
roots =
      (Declaration -> Bool) -> Set Declaration -> Set Declaration
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
        ( \Declaration
d ->
            (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
              (Regex -> String -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
`matchTest` Declaration -> String
displayDeclaration Declaration
d)
              [Regex]
rootPatterns
        )
        ( Analysis -> Set Declaration
outputableDeclarations Analysis
analysis )
    
    matchingModules :: Set (GenModule Unit)
matchingModules = 
      (GenModule Unit -> Bool)
-> Set (GenModule Unit) -> Set (GenModule Unit)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter 
        ((\String
s -> (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Regex -> String -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
`matchTest` String
s) [Regex]
rootModules) (String -> Bool)
-> (GenModule Unit -> String) -> GenModule Unit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString (ModuleName -> String)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName) 
      ( Map (GenModule Unit) (Set Declaration) -> Set (GenModule Unit)
forall k a. Map k a -> Set k
Map.keysSet (Map (GenModule Unit) (Set Declaration) -> Set (GenModule Unit))
-> Map (GenModule Unit) (Set Declaration) -> Set (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ Analysis -> Map (GenModule Unit) (Set Declaration)
exports Analysis
analysis )

    reachableSet :: Set Declaration
reachableSet =
      Analysis -> Set Root -> Set Declaration
reachable
        Analysis
analysis
        ( (Declaration -> Root) -> Set Declaration -> Set Root
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Declaration -> Root
DeclarationRoot Set Declaration
roots 
        Set Root -> Set Root -> Set Root
forall a. Semigroup a => a -> a -> a
<> (GenModule Unit -> Root) -> Set (GenModule Unit) -> Set Root
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map GenModule Unit -> Root
ModuleRoot Set (GenModule Unit)
matchingModules 
        Set Root -> Set Root -> Set Root
forall a. Semigroup a => a -> a -> a
<> Analysis -> Set Root -> Set Root
filterImplicitRoots Analysis
analysis ( Analysis -> Set Root
implicitRoots Analysis
analysis ) 
        )

    -- We only care about dead declarations if they have a span assigned,
    -- since they don't show up in the output otherwise
    dead :: Set Declaration
dead =
      Analysis -> Set Declaration
outputableDeclarations Analysis
analysis Set Declaration -> Set Declaration -> Set Declaration
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Declaration
reachableSet

    warnings :: Map String [((String, (Int, Int)), Declaration)]
warnings =
      ([((String, (Int, Int)), Declaration)]
 -> [((String, (Int, Int)), Declaration)]
 -> [((String, (Int, Int)), Declaration)])
-> [Map String [((String, (Int, Int)), Declaration)]]
-> Map String [((String, (Int, Int)), Declaration)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [((String, (Int, Int)), Declaration)]
-> [((String, (Int, Int)), Declaration)]
-> [((String, (Int, Int)), Declaration)]
forall a. [a] -> [a] -> [a]
(++) ([Map String [((String, (Int, Int)), Declaration)]]
 -> Map String [((String, (Int, Int)), Declaration)])
-> [Map String [((String, (Int, Int)), Declaration)]]
-> Map String [((String, (Int, Int)), Declaration)]
forall a b. (a -> b) -> a -> b
$
      (Declaration -> [Map String [((String, (Int, Int)), Declaration)]])
-> Set Declaration
-> [Map String [((String, (Int, Int)), Declaration)]]
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( \Declaration
d ->
            Maybe [Map String [((String, (Int, Int)), Declaration)]]
-> [Map String [((String, (Int, Int)), Declaration)]]
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe [Map String [((String, (Int, Int)), Declaration)]]
 -> [Map String [((String, (Int, Int)), Declaration)]])
-> Maybe [Map String [((String, (Int, Int)), Declaration)]]
-> [Map String [((String, (Int, Int)), Declaration)]]
forall a b. (a -> b) -> a -> b
$ do
              String
moduleFilePath <- GenModule Unit -> Map (GenModule Unit) String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ( Declaration -> GenModule Unit
declModule Declaration
d ) ( Analysis -> Map (GenModule Unit) String
modulePaths Analysis
analysis )
              let packageName :: String
packageName = Unit -> String
forall u. IsUnitId u => u -> String
unitString (Unit -> String) -> (Declaration -> Unit) -> Declaration -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule Unit -> Unit)
-> (Declaration -> GenModule Unit) -> Declaration -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> GenModule Unit
declModule (Declaration -> String) -> Declaration -> String
forall a b. (a -> b) -> a -> b
$ Declaration
d
              Set (Int, Int)
starts <- Declaration
-> Map Declaration (Set (Int, Int)) -> Maybe (Set (Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Declaration
d ( Analysis -> Map Declaration (Set (Int, Int))
declarationSites Analysis
analysis )
              let locs :: [(String, (Int, Int))]
locs = (,) String
packageName ((Int, Int) -> (String, (Int, Int)))
-> [(Int, Int)] -> [(String, (Int, Int))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
Set.toList Set (Int, Int)
starts
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Int, Int)
starts
              [Map String [((String, (Int, Int)), Declaration)]]
-> Maybe [Map String [((String, (Int, Int)), Declaration)]]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [ String
-> [((String, (Int, Int)), Declaration)]
-> Map String [((String, (Int, Int)), Declaration)]
forall k a. k -> a -> Map k a
Map.singleton String
moduleFilePath ( ((String, (Int, Int))
 -> Declaration -> ((String, (Int, Int)), Declaration))
-> [(String, (Int, Int))]
-> [Declaration]
-> [((String, (Int, Int)), Declaration)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) [(String, (Int, Int))]
locs (Declaration -> [Declaration]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
d) ) ]
        )
        Set Declaration
dead

    weeds :: [Weed]
weeds =
      Map String [((String, (Int, Int)), Declaration)]
-> [(String, [((String, (Int, Int)), Declaration)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map String [((String, (Int, Int)), Declaration)]
warnings [(String, [((String, (Int, Int)), Declaration)])]
-> ([(String, [((String, (Int, Int)), Declaration)])] -> [Weed])
-> [Weed]
forall a b. a -> (a -> b) -> b
& ((String, [((String, (Int, Int)), Declaration)]) -> [Weed])
-> [(String, [((String, (Int, Int)), Declaration)])] -> [Weed]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap \( String
weedPath, [((String, (Int, Int)), Declaration)]
declarations ) ->
        (((String, (Int, Int)), Declaration) -> (String, (Int, Int)))
-> [((String, (Int, Int)), Declaration)]
-> [((String, (Int, Int)), Declaration)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((String, (Int, Int)), Declaration) -> (String, (Int, Int))
forall a b. (a, b) -> a
fst [((String, (Int, Int)), Declaration)]
declarations [((String, (Int, Int)), Declaration)]
-> ([((String, (Int, Int)), Declaration)] -> [Weed]) -> [Weed]
forall a b. a -> (a -> b) -> b
& (((String, (Int, Int)), Declaration) -> Weed)
-> [((String, (Int, Int)), Declaration)] -> [Weed]
forall a b. (a -> b) -> [a] -> [b]
map \( (String
weedPackage, (Int
weedLine, Int
weedCol)) , Declaration
weedDeclaration ) ->
          Weed { weedPrettyPrintedType :: Maybe String
weedPrettyPrintedType = Declaration -> Map Declaration String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Declaration
weedDeclaration (Analysis -> Map Declaration String
prettyPrintedType Analysis
analysis)
               , String
weedPackage :: String
weedPackage :: String
weedPackage
               , String
weedPath :: String
weedPath :: String
weedPath
               , Int
weedLine :: Int
weedLine :: Int
weedLine
               , Int
weedCol :: Int
weedCol :: Int
weedCol
               , Declaration
weedDeclaration :: Declaration
weedDeclaration :: Declaration
weedDeclaration
               }

  in ([Weed]
weeds, Analysis
analysis)

  where

    filterImplicitRoots :: Analysis -> Set Root -> Set Root
    filterImplicitRoots :: Analysis -> Set Root -> Set Root
filterImplicitRoots Analysis{ Map Declaration String
prettyPrintedType :: Analysis -> Map Declaration String
prettyPrintedType :: Map Declaration String
prettyPrintedType, Map (GenModule Unit) String
modulePaths :: Analysis -> Map (GenModule Unit) String
modulePaths :: Map (GenModule Unit) String
modulePaths } = (Root -> Bool) -> Set Root -> Set Root
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((Root -> Bool) -> Set Root -> Set Root)
-> (Root -> Bool) -> Set Root -> Set Root
forall a b. (a -> b) -> a -> b
$ \case
      DeclarationRoot Declaration
_ -> Bool
True -- keep implicit roots for rewrite rules etc

      ModuleRoot GenModule Unit
_ -> Bool
True

      InstanceRoot Declaration
d Declaration
c -> Bool
typeClassRoots Bool -> Bool -> Bool
|| Bool
matchingType
        where
          matchingType :: Bool
matchingType = 
            let mt :: Maybe String
mt = Declaration -> Map Declaration String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Declaration
d Map Declaration String
prettyPrintedType
                matches :: Regex -> Bool
matches = (Regex -> Bool)
-> (String -> Regex -> Bool) -> Maybe String -> Regex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Regex -> Bool
forall a b. a -> b -> a
const Bool
False) ((Regex -> String -> Bool) -> String -> Regex -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Regex -> String -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
matchTest) Maybe String
mt
            in (Maybe Regex -> Bool) -> [Maybe Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> (Regex -> Bool) -> Maybe Regex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Regex -> Bool
matches) [Maybe Regex]
filteredInstances

          filteredInstances :: [Maybe Regex]
filteredInstances = 
            (InstancePattern Regex -> Maybe Regex)
-> [InstancePattern Regex] -> [Maybe Regex]
forall a b. (a -> b) -> [a] -> [b]
map InstancePattern Regex -> Maybe Regex
forall a. InstancePattern a -> Maybe a
instancePattern 
            ([InstancePattern Regex] -> [Maybe Regex])
-> ([InstancePattern Regex] -> [InstancePattern Regex])
-> [InstancePattern Regex]
-> [Maybe Regex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstancePattern Regex -> Bool)
-> [InstancePattern Regex] -> [InstancePattern Regex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (Regex -> Bool) -> Maybe Regex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Regex -> String -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
`matchTest` Declaration -> String
displayDeclaration Declaration
c) (Maybe Regex -> Bool)
-> (InstancePattern Regex -> Maybe Regex)
-> InstancePattern Regex
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstancePattern Regex -> Maybe Regex
forall a. InstancePattern a -> Maybe a
classPattern) 
            ([InstancePattern Regex] -> [InstancePattern Regex])
-> ([InstancePattern Regex] -> [InstancePattern Regex])
-> [InstancePattern Regex]
-> [InstancePattern Regex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstancePattern Regex -> Bool)
-> [InstancePattern Regex] -> [InstancePattern Regex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (Regex -> Bool) -> Maybe Regex -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Regex -> Bool
forall {regex}. RegexLike regex String => regex -> Bool
modulePathMatches (Maybe Regex -> Bool)
-> (InstancePattern Regex -> Maybe Regex)
-> InstancePattern Regex
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstancePattern Regex -> Maybe Regex
forall a. InstancePattern a -> Maybe a
modulePattern) 
            ([InstancePattern Regex] -> [Maybe Regex])
-> [InstancePattern Regex] -> [Maybe Regex]
forall a b. (a -> b) -> a -> b
$ [InstancePattern Regex]
rootInstances

          modulePathMatches :: regex -> Bool
modulePathMatches regex
p = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (regex
p regex -> String -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
`matchTest`) (GenModule Unit -> Map (GenModule Unit) String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ( Declaration -> GenModule Unit
declModule Declaration
d ) Map (GenModule Unit) String
modulePaths)


displayDeclaration :: Declaration -> String
displayDeclaration :: Declaration -> String
displayDeclaration Declaration
d = 
  ModuleName -> String
moduleNameString ( GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName ( Declaration -> GenModule Unit
declModule Declaration
d ) ) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> OccName -> String
occNameString ( Declaration -> OccName
declOccName Declaration
d )