Add root-modules field (ocharles#157)

README.md

@@ -95,7 +95,8 @@ in the Dhall project).
 | ---------------- | ------------------------------------ | --- |
 | roots            | `[ "Main.main", "^Paths_weeder.*" ]` | Any declarations matching these regular expressions will be considered as alive. |
 | type-class-roots | `false`                              | Consider all instances of type classes as roots. Overrides `root-instances`. |
-| root-instances   | `[ {class = '\.IsString$'}, {class = '\.IsList$'} ]` | Type class instances that match on all specified fields will be considered as roots. Accepts the fields `instance` matching on the pretty-printed type of the instance (visible in the output), `class` matching on its parent class declaration, and `module` matching on the module the instance is in. |
+| root-instances   | `[ {class = '\.IsString$'}, {class = '\.IsList$'} ]` | Type class instances that match on all specified fields will be considered as roots. Accepts the fields `instance` matching on the pretty-printed type of the instance (visible in the output), `class` matching on its parent class declaration, and `module` matching on the module the instance is defined in. |
+| root-modules     | `[]`                                 | The exports of all matching modules will be considered as alive. This does not include type class instances implicitly exported by the module.
 | unused-types     | `false`                              | Enable analysis of unused types. |
 
 `root-instances` can also accept string literals as a shorthand for writing a table

src/Weeder.hs

@@ -56,6 +56,7 @@ import qualified Data.Tree as Tree
 import Data.Generics.Labels ()
 
 -- ghc
+import GHC.Types.Avail ( AvailInfo, availName, availNames )
 import GHC.Data.FastString ( unpackFS )
 import GHC.Iface.Ext.Types
   ( BindType( RegularBind )
@@ -64,7 +65,7 @@ import GHC.Iface.Ext.Types
   , EvVarSource ( EvInstBind, cls )
   , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo )
   , HieASTs( HieASTs )
-  , HieFile( HieFile, hie_asts, hie_module, hie_hs_file, hie_types )
+  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file, hie_types )
   , HieType( HTyVarTy, HAppTy, HTyConApp, HForAllTy, HFunTy, HQualTy, HLitTy, HCastTy, HCoercionTy )
   , HieArgs( HieArgs )
   , HieTypeFix( Roll )
@@ -270,14 +271,16 @@ analyseHieFile weederConfig hieFile =
 
 analyseHieFile' :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => m ()
 analyseHieFile' = do
-  HieFile{ hie_asts = HieASTs hieASTs, hie_module, hie_hs_file } <- asks currentHieFile
+  HieFile{ hie_asts = HieASTs hieASTs, hie_exports, hie_module, hie_hs_file } <- asks currentHieFile
   #modulePaths %= Map.insert hie_module hie_hs_file
 
   g <- asks initialGraph
   #dependencyGraph %= overlay g
 
   for_ hieASTs topLevelAnalysis
 
+  for_ hie_exports ( analyseExport hie_module )
+
 
 lookupType :: HieFile -> TypeIndex -> HieTypeFix
 lookupType hf t = recoverFullType t $ hie_types hf
@@ -324,6 +327,15 @@ typeToNames (Roll t) = case t of
     hieArgsTypes = foldMap (typeToNames . snd) . filter fst
 
 
+analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m ()
+analyseExport m a = 
+  traverse_ (traverse_ addExport . nameToDeclaration) (availName a : availNames a)
+  where
+
+    addExport :: MonadState Analysis m => Declaration -> m ()
+    addExport d = #exports %= Map.insertWith (<>) m ( Set.singleton d )
+
+
 -- | @addDependency x y@ adds the information that @x@ depends on @y@.
 addDependency :: MonadState Analysis m => Declaration -> Declaration -> m ()
 addDependency x y =

src/Weeder/Config.hs

@@ -69,7 +69,9 @@ data ConfigType a = Config
   , unusedTypes :: Bool
     -- ^ Toggle to look for and output unused types. Type family instances will
     -- be marked as implicit roots.
-  } deriving (Eq, Show)
+  , rootModules :: [a]
+    -- ^ All matching modules will be added to the root set.
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
 
 
 -- | Construct via InstanceOnly, ClassOnly or ModuleOnly, 
@@ -100,6 +102,7 @@ defaultConfig = Config
   , typeClassRoots = False
   , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ]
   , unusedTypes = False
+  , rootModules = mempty
   }
 
 
@@ -115,6 +118,7 @@ instance TOML.DecodeTOML ConfigParsed where
     typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots"
     rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" 
     unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types"
+    rootModules <- TOML.getFieldOr (rootModules defaultConfig) "root-modules"
 
     pure Config{..}
 
@@ -125,6 +129,7 @@ decodeNoDefaults = do
   typeClassRoots <- TOML.getField "type-class-roots"
   rootInstances <- TOML.getField "root-instances"
   unusedTypes <- TOML.getField "unused-types"
+  rootModules <- TOML.getField "root-modules"
 
   either fail pure $ compileConfig Config{..}
 
@@ -181,10 +186,13 @@ compileRegex = bimap show (\p -> patternToRegex p defaultCompOpt defaultExecOpt)
 
 
 compileConfig :: ConfigParsed -> Either String Config
-compileConfig conf@Config{ rootInstances, rootPatterns } = do
-  rootInstances' <- traverse (traverse compileRegex) . nubOrd $ rootInstances
-  rootPatterns' <- traverse compileRegex $ nubOrd rootPatterns
-  pure conf{ rootInstances = rootInstances', rootPatterns = rootPatterns' }
+compileConfig conf@Config{ rootInstances, rootPatterns, rootModules } = 
+  traverse compileRegex conf'
+  where
+    rootInstances' = nubOrd rootInstances
+    rootPatterns' = nubOrd rootPatterns
+    rootModules' = nubOrd rootModules
+    conf' = conf{ rootInstances = rootInstances', rootPatterns = rootPatterns', rootModules = rootModules' }
 
 
 configToToml :: ConfigParsed -> String
@@ -194,6 +202,7 @@ configToToml Config{..}
       , "type-class-roots = " ++ map toLower (show typeClassRoots)
       , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]"
       , "unused-types = " ++ map toLower (show unusedTypes)
+      , "root-modules = " ++ show rootModules
       ]
   where
     rootInstances' = rootInstances

src/Weeder/Run.hs

@@ -19,12 +19,12 @@ import qualified Data.Set as Set
 import qualified Data.Map.Strict as Map
 
 -- ghc
-import GHC.Plugins 
+import GHC.Plugins
   ( occNameString
   , unitString
   , moduleUnit
   , moduleName
-  , moduleNameString 
+  , moduleNameString
   )
 import GHC.Iface.Ext.Types ( HieFile( hie_asts ), getAsts )
 import GHC.Iface.Ext.Utils (generateReferencesMap)
@@ -66,7 +66,7 @@ formatWeed Weed{..} =
 -- Returns a list of 'Weed's that can be displayed using
 -- 'formatWeed', and the final 'Analysis'.
 runWeeder :: Config -> [HieFile] -> ([Weed], Analysis)
-runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hieFiles =
+runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances, rootModules } hieFiles =
   let 
     asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles
 
@@ -100,11 +100,19 @@ runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hie
               rootPatterns
         )
         ( outputableDeclarations analysis )
+
+    matchingModules = 
+      Set.filter 
+        ((\s -> any (`matchTest` s) rootModules) . moduleNameString . moduleName) 
+      ( Map.keysSet $ exports analysis )
 
     reachableSet =
       reachable
         analysis
-        ( Set.map DeclarationRoot roots <> filterImplicitRoots analysis ( implicitRoots analysis ) )
+        ( Set.map DeclarationRoot roots 
+        <> Set.map ModuleRoot matchingModules 
+        <> filterImplicitRoots analysis ( implicitRoots analysis ) 
+        )
 
     -- We only care about dead declarations if they have a span assigned,
     -- since they don't show up in the output otherwise

test/Spec/ModuleRoot.stdout

@@ -0,0 +1,2 @@
+test/Spec/ModuleRoot/InstanceNotRoot.hs:9: (Instance) :: C T
+test/Spec/ModuleRoot/M.hs:11: weed

test/Spec/ModuleRoot.toml

@@ -0,0 +1,5 @@
+roots = []
+
+root-modules = [ '^Spec\.ModuleRoot\.M$', '^Spec\.ModuleRoot\.InstanceNotRoot$' ]
+
+type-class-roots = false

test/Spec/ModuleRoot/InstanceNotRoot.hs

@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+module Spec.ModuleRoot.InstanceNotRoot (C(..), T(..)) where
+
+class C a where
+  method :: a -> a
+
+data T = T
+
+instance C T where
+  method = id

test/Spec/ModuleRoot/M.hs

@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+module Spec.ModuleRoot.M (root) where
+
+root :: ()
+root = dependency
+
+dependency :: ()
+dependency = ()
+
+weed :: ()
+weed = ()

test/UnitTests/Weeder/ConfigSpec.hs

@@ -19,6 +19,7 @@ configToTomlTests =
         , typeClassRoots = True
         , rootInstances = [InstanceOnly "Quux\\\\[\\]", ClassOnly "[\\[\\\\[baz" <> ModuleOnly "[Quuux]", InstanceOnly "[\\[\\\\[baz" <> ClassOnly "[Quuux]" <> ModuleOnly "[Quuuux]"]
         , unusedTypes = True
+        , rootModules = ["Foo\\.Bar", "Baz"]
         }
       cf' = T.pack $ configToToml cf
    in TOML.decode cf' `shouldBe` Right cf

weeder.cabal

@@ -98,6 +98,8 @@ test-suite weeder-test
     Spec.DeriveGeneric.DeriveGeneric
     Spec.InstanceRootConstraint.InstanceRootConstraint
     Spec.InstanceTypeclass.InstanceTypeclass
+    Spec.ModuleRoot.InstanceNotRoot
+    Spec.ModuleRoot.M
     Spec.Monads.Monads
     Spec.NumInstance.NumInstance
     Spec.NumInstanceLiteral.NumInstanceLiteral