{-# language ApplicativeDo #-}
{-# language BlockArguments #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}

-- | This module provides an entry point to the Weeder executable.

module Weeder.Main ( main, mainWithConfig ) where

-- algebraic-graphs
import Algebra.Graph.Export.Dot ( export, defaultStyleViaShow )

-- base
import Control.Exception ( evaluate )
import Control.Monad ( guard, unless, when )
import Control.Monad.IO.Class ( liftIO )
import Data.Bool
import Data.Foldable
import Data.IORef ( atomicModifyIORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
import Data.Version ( showVersion )
import System.Exit ( exitFailure )

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

-- text
import qualified Data.Text as T

-- dhall
import qualified Dhall

-- directory
import System.Directory ( canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory )

-- filepath
import System.FilePath ( isExtensionOf )

-- ghc
import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), NameCacheUpdater( NCU ), readHieFileWithVersion )
import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion )
import GHC.Unit.Module ( moduleName, moduleNameString )
import GHC.Types.Name.Cache ( initNameCache, NameCache )
import GHC.Types.Name ( occNameString )
import GHC.Types.SrcLoc ( RealSrcLoc, realSrcSpanStart, srcLocLine )
import GHC.Types.Unique.Supply ( mkSplitUniqSupply )

-- regex-tdfa
import Text.Regex.TDFA ( (=~) )

-- optparse-applicative
import Options.Applicative

-- transformers
import Control.Monad.Trans.State.Strict ( execStateT )

-- weeder
import Weeder
import Weeder.Config
import Paths_weeder (version)


-- | Parse command line arguments and into a 'Config' and run 'mainWithConfig'.
main :: IO ()
main :: IO ()
main = do
  (Text
configExpr, String
hieExt, [String]
hieDirectories, Bool
requireHsFiles) <-
    forall a. ParserInfo a -> IO a
execParser forall a b. (a -> b) -> a -> b
$
      forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (Text, String, [String], Bool)
optsP forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
versionP) forall a. Monoid a => a
mempty

  forall a. Decoder a -> Text -> IO a
Dhall.input Decoder Config
config Text
configExpr
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [String] -> Bool -> Config -> IO ()
mainWithConfig String
hieExt [String]
hieDirectories Bool
requireHsFiles
  where
    optsP :: Parser (Text, String, [String], Bool)
optsP = (,,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"config"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"A Dhall expression for Weeder's configuration. Can either be a file path (a Dhall import) or a literal Dhall expression."
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Text
"./weeder.dhall"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"<weeder.dhall>"
                forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). (a -> String) -> Mod f a
showDefaultWith Text -> String
T.unpack
            )
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hie-extension"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
".hie"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Extension of HIE files"
                forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Show a => Mod f a
showDefault
            )
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (
            forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hie-directory"
                    forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"A directory to look for .hie files in. Maybe specified multiple times. Default ./."
                )
            )
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
              ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"require-hs-files"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Skip stale .hie files with no matching .hs modules"
              )

    versionP :: Parser (a -> a)
versionP = forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption ( String
"weeder version "
                            forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
version
                            forall a. Semigroup a => a -> a -> a
<> String
"\nhie version "
                            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
hieVersion )
        ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Show version" )


-- | Run Weeder in the current working directory with a given 'Config'.
--
-- This will recursively find all files with the given extension in the given directories, perform
-- analysis, and report all unused definitions according to the 'Config'.
mainWithConfig :: String -> [FilePath] -> Bool -> Config -> IO ()
mainWithConfig :: String -> [String] -> Bool -> Config -> IO ()
mainWithConfig String
hieExt [String]
hieDirectories Bool
requireHsFiles Config{ Set String
rootPatterns :: Config -> Set String
rootPatterns :: Set String
rootPatterns, Bool
typeClassRoots :: Config -> Bool
typeClassRoots :: Bool
typeClassRoots } = do
  [String]
hieFilePaths <-
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( String -> String -> IO [String]
getFilesIn String
hieExt )
        ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
hieDirectories
          then [String
"./."]
          else [String]
hieDirectories
        )

  [String]
hsFilePaths <-
    if Bool
requireHsFiles
      then String -> String -> IO [String]
getFilesIn String
".hs" String
"./."
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  NameCacheUpdater
nameCacheUpdater <-
    IO NameCacheUpdater
mkNameCacheUpdater

  Analysis
analysis <-
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Analysis
emptyAnalysis do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
hieFilePaths \String
hieFilePath -> do
        HieFile
hieFileResult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ( NameCacheUpdater -> String -> IO HieFile
readCompatibleHieFileOrExit NameCacheUpdater
nameCacheUpdater String
hieFilePath )
        let hsFileExists :: Bool
hsFileExists = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( HieFile -> String
hie_hs_file HieFile
hieFileResult forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ) [String]
hsFilePaths
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
requireHsFiles Bool -> Bool -> Bool
==> Bool
hsFileExists) do
          forall (m :: * -> *). MonadState Analysis m => HieFile -> m ()
analyseHieFile HieFile
hieFileResult

  let
    roots :: Set Declaration
roots =
      forall a. (a -> Bool) -> Set a -> Set a
Set.filter
        ( \Declaration
d ->
            forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
              ( ( ModuleName -> String
moduleNameString ( forall unit. GenModule unit -> ModuleName
moduleName ( Declaration -> Module
declModule Declaration
d ) ) forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> OccName -> String
occNameString ( Declaration -> OccName
declOccName Declaration
d ) ) forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ )
              Set String
rootPatterns
        )
        ( Analysis -> Set Declaration
allDeclarations Analysis
analysis )

    reachableSet :: Set Declaration
reachableSet =
      Analysis -> Set Root -> Set Declaration
reachable
        Analysis
analysis
        ( forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Declaration -> Root
DeclarationRoot Set Declaration
roots forall a. Semigroup a => a -> a -> a
<> forall a. a -> a -> Bool -> a
bool forall a. Monoid a => a
mempty ( forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Declaration -> Root
DeclarationRoot ( Analysis -> Set Declaration
implicitRoots Analysis
analysis ) ) Bool
typeClassRoots )

    dead :: Set Declaration
dead =
      Analysis -> Set Declaration
allDeclarations Analysis
analysis forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Declaration
reachableSet

    warnings :: Map String [(RealSrcLoc, Declaration)]
warnings =
      forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( \Declaration
d ->
            forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ do
              String
moduleFilePath <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ( Declaration -> Module
declModule Declaration
d ) ( Analysis -> Map Module String
modulePaths Analysis
analysis )
              Set RealSrcSpan
spans <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Declaration
d ( Analysis -> Map Declaration (Set RealSrcSpan)
declarationSites Analysis
analysis )
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set RealSrcSpan
spans
              let starts :: [RealSrcLoc]
starts = forall a b. (a -> b) -> [a] -> [b]
map RealSrcSpan -> RealSrcLoc
realSrcSpanStart forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set RealSrcSpan
spans
              return [ forall k a. k -> a -> Map k a
Map.singleton String
moduleFilePath ( forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) [RealSrcLoc]
starts (forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
d) ) ]
        )
        Set Declaration
dead

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ( forall k a. Map k a -> [(k, a)]
Map.toList Map String [(RealSrcLoc, Declaration)]
warnings ) \( String
path, [(RealSrcLoc, Declaration)]
declarations ) ->
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(RealSrcLoc, Declaration)]
declarations \( RealSrcLoc
start, Declaration
d ) ->
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String -> RealSrcLoc -> Declaration -> String
showWeed String
path RealSrcLoc
start Declaration
d

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ( forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map String [(RealSrcLoc, Declaration)]
warnings ) forall a. IO a
exitFailure

showWeed :: FilePath -> RealSrcLoc -> Declaration -> String
showWeed :: String -> RealSrcLoc -> Declaration -> String
showWeed String
path RealSrcLoc
start Declaration
d =
  String
path forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ( RealSrcLoc -> Int
srcLocLine RealSrcLoc
start ) forall a. Semigroup a => a -> a -> a
<> String
": "
    forall a. Semigroup a => a -> a -> a
<> OccName -> String
occNameString ( Declaration -> OccName
declOccName Declaration
d)


-- | Recursively search for files with the given extension in given directory
getFilesIn
  :: String
  -- ^ Only files with this extension are considered
  -> FilePath
  -- ^ Directory to look in
  -> IO [FilePath]
getFilesIn :: String -> String -> IO [String]
getFilesIn String
ext String
path = do
  Bool
exists <-
    String -> IO Bool
doesPathExist String
path

  if Bool
exists
    then do
      Bool
isFile <-
        String -> IO Bool
doesFileExist String
path

      if Bool
isFile Bool -> Bool -> Bool
&& String
ext String -> String -> Bool
`isExtensionOf` String
path
        then do
          String
path' <-
            String -> IO String
canonicalizePath String
path

          return [ String
path' ]

        else do
          Bool
isDir <-
            String -> IO Bool
doesDirectoryExist String
path

          if Bool
isDir
            then do
              [String]
cnts <-
                String -> IO [String]
listDirectory String
path

              forall a. String -> IO a -> IO a
withCurrentDirectory String
path ( forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( String -> String -> IO [String]
getFilesIn String
ext ) [String]
cnts )

            else
              forall (m :: * -> *) a. Monad m => a -> m a
return []

    else
      forall (m :: * -> *) a. Monad m => a -> m a
return []


-- | Read a .hie file, exiting if it's an incompatible version.
readCompatibleHieFileOrExit :: NameCacheUpdater -> FilePath -> IO HieFile
readCompatibleHieFileOrExit :: NameCacheUpdater -> String -> IO HieFile
readCompatibleHieFileOrExit NameCacheUpdater
nameCacheUpdater String
path = do
  Either HieHeader HieFileResult
res <- (HieHeader -> Bool)
-> NameCacheUpdater
-> String
-> IO (Either HieHeader HieFileResult)
readHieFileWithVersion (\(Integer
v, ByteString
_) -> Integer
v forall a. Eq a => a -> a -> Bool
== Integer
hieVersion) NameCacheUpdater
nameCacheUpdater String
path
  case Either HieHeader HieFileResult
res of
    Right HieFileResult{ HieFile
hie_file_result :: HieFile
hie_file_result :: HieFileResult -> HieFile
hie_file_result } ->
      forall (m :: * -> *) a. Monad m => a -> m a
return HieFile
hie_file_result
    Left ( Integer
v, ByteString
_ghcVersion ) -> do
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"incompatible hie file: " forall a. Semigroup a => a -> a -> a
<> String
path
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"    this version of weeder was compiled with GHC version "
               forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
hieVersion
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"    the hie files in this project were generated with GHC version "
               forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
v
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"    weeder must be built with the same GHC version"
               forall a. Semigroup a => a -> a -> a
<> String
" as the project it is used on"
      forall a. IO a
exitFailure


mkNameCacheUpdater :: IO NameCacheUpdater
mkNameCacheUpdater :: IO NameCacheUpdater
mkNameCacheUpdater = do
  NameCache
nameCache <- do
    UniqSupply
uniqSupply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'z'
    return ( UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
uniqSupply [] )

  IORef NameCache
nameCacheRef <- forall a. a -> IO (IORef a)
newIORef NameCache
nameCache

  let update_nc :: (NameCache -> (NameCache, b)) -> IO b
update_nc NameCache -> (NameCache, b)
f = do b
r <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef NameCache
nameCacheRef NameCache -> (NameCache, b)
f
                       NameCache
_ <- forall a. a -> IO a
evaluate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef NameCache
nameCacheRef
                       return b
r
  forall (m :: * -> *) a. Monad m => a -> m a
return ((forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU forall c. (NameCache -> (NameCache, c)) -> IO c
update_nc)


infixr 5 ==>


-- | An infix operator for logical implication
(==>) :: Bool -> Bool -> Bool
Bool
True  ==> :: Bool -> Bool -> Bool
==> Bool
x = Bool
x
Bool
False ==> Bool
_ = Bool
True