Discover more modules (exes, sub-libraries, test-suites) (#16)

exe Main modules are prefixed with the exe name, fixing this
old graphmod bug: yav/graphmod#28

Makefile

@@ -6,6 +6,10 @@ exe-repl: graphex.cabal
 	cabal repl exe:graphex
 .PHONY: exe-repl
 
+test-repl: graphex.cabal
+	cabal repl tests
+.PHONY: test-repl
+
 graphex.cabal: package.yaml
 	hpack
 
@@ -14,10 +18,15 @@ install: graphex.cabal
 .PHONY: install
 
 test: graphex.cabal
-	cabal test
+	cabal test --test-show-details=streaming
 .PHONY: test
 
 fmt:
 	fd .hs src --exec stylish-haskell -i
 	fd .hs test --exec stylish-haskell -i
+	fd .hs app --exec stylish-haskell -i
 .PHONY: fmt
+
+graph.json:
+	cabal run -v0 exe:graphex -- cabal > graph.json
+.PHONY: graph.json

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 module Main where
 
 import           Control.Applicative  ((<|>))
@@ -9,13 +10,17 @@ import           Data.Foldable
 import           Data.List.NonEmpty   (NonEmpty (..))
 import qualified Data.List.NonEmpty   as NE
 import           Data.Maybe           (fromMaybe)
+import qualified Data.Set             as Set
 import           Data.Text            (Text)
 import qualified Data.Text            as T
 import qualified Data.Text.IO         as TIO
 import           Data.Tree.View       (drawTree)
-import           Options.Applicative  (Parser, argument, command, customExecParser, fullDesc, help, helper, hsubparser,
-                                       info, long, metavar, prefs, progDesc, short, showDefault, showHelpOnError, some,
-                                       str, strOption, switch, value, (<**>))
+import           Options.Applicative  (Parser, argument, command,
+                                       customExecParser, fullDesc, help, helper,
+                                       hsubparser, info, long, metavar, prefs,
+                                       progDesc, short, showDefault,
+                                       showHelpOnError, some, str, strOption,
+                                       switch, value, (<**>))
 
 import           Graphex
 import           Graphex.Cabal
@@ -44,16 +49,24 @@ data GraphOptions = GraphOptions {
     optCommand :: Command
     } deriving stock Show
 
-data CabalOptions = CabalOptions deriving stock Show
-
 options :: Parser Options
 options = hsubparser $ fold
   [ command "graph" (info (GraphCmd <$> graphOptions) (progDesc "Graph operations"))
   , command "cabal" (info (CabalCmd <$> cabalOptions) (progDesc "Cabal operations"))
   ]
 
+data CabalOptions = CabalOptions
+  { optDiscoverExes    :: Bool
+  , optDiscoverTests   :: Bool
+  , optIncludeExternal :: Bool
+  } deriving stock Show
+
 cabalOptions :: Parser CabalOptions
-cabalOptions = pure CabalOptions
+cabalOptions = do
+  optDiscoverExes <- switch (long "discover-exes" <> help "Discover exe import dependencies")
+  optDiscoverTests <- switch (long "discover-tests" <> help "Discover test import dependencies")
+  optIncludeExternal <- switch (long "include-external" <> help "Include external import dependencies")
+  pure CabalOptions{..}
 
 graphOptions :: Parser GraphOptions
 graphOptions = GraphOptions
@@ -107,8 +120,15 @@ main = customExecParser (prefs showHelpOnError) opts >>= \case
         FindLongest      -> printStrs $ longest graph
         Select m         -> BL.putStr $ encode (graphToDep (handleReverse (setAttribute m "note" "start" $ restrictTo graph (allDepsOn graph m))))
         ToCSV noHeader   -> BL.putStr $ (if noHeader then CSV.encode else CSV.encodeDefaultOrderedByName) $ Graphex.CSV.toEdges graph
-  CabalCmd CabalOptions{} -> do
-    mg <- discoverCabalModuleGraph
+  CabalCmd CabalOptions{..} -> do
+    mg <- discoverCabalModuleGraph CabalDiscoverOpts
+      { toDiscover = mconcat
+          [ Set.singleton CabalLibraries
+          , bool mempty (Set.singleton CabalExecutables) optDiscoverExes
+          , bool mempty (Set.singleton CabalTests) optDiscoverTests
+          ]
+      , includeExternal = optIncludeExternal
+      }
     BL.putStr $ encode $ toLookingGlass "Internal Package Dependencies" mempty mg
   where
     opts = info (options <**> helper) ( fullDesc <> progDesc "Graph CLI tool.")

src/Graphex/Cabal.hs

@@ -3,15 +3,21 @@
 {-# LANGUAGE OverloadedStrings   #-}
 
 -- Cribbed from graphmod's 'Graphmod.CabalSupport'
-module Graphex.Cabal (discoverCabalModules, discoverCabalModuleGraph) where
+module Graphex.Cabal
+  ( discoverCabalModules
+  , discoverCabalModuleGraph
+  , CabalDiscoverOpts (..)
+  , CabalModuleType (..)
+  ) where
 
 import           Graphex.Core
 import           Graphex.Parser
 
-import           Control.Monad                                 (filterM)
+import           Control.Monad                                 (guard)
 import           Data.Foldable                                 (fold)
 import           Data.List                                     (intersperse)
 import           Data.Maybe                                    (maybeToList)
+import           Data.Set                                      (Set)
 import qualified Data.Set                                      as Set
 import           Data.String                                   (fromString)
 import           Data.Traversable                              (for)
@@ -21,10 +27,14 @@ import           System.FilePath                               (takeExtension,
                                                                 (<.>), (</>))
 
 -- Interface to cabal.
+
 import qualified Distribution.ModuleName                       as Cabal
 import           Distribution.PackageDescription               (BuildInfo (..),
+                                                                Executable (..),
                                                                 Library (..),
-                                                                PackageDescription (..))
+                                                                PackageDescription (..),
+                                                                TestSuite (..),
+                                                                unUnqualComponentName)
 import           Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import           Distribution.Verbosity                        (silent)
 
@@ -54,30 +64,78 @@ sourceDirToFilePath :: FilePath -> FilePath
 sourceDirToFilePath = id
 #endif
 
-discoverCabalModules :: FilePath -> IO [Module]
-discoverCabalModules cabalFile = do
+discoverCabalModules :: CabalDiscoverOpts -> FilePath -> IO [Module]
+discoverCabalModules CabalDiscoverOpts{..} cabalFile = do
   gpd <- readGenericPackageDescription silent cabalFile
   let PackageDescription{..} = flattenPackageDescription gpd
   let candidateModules = mconcat
         [ do
-            Library{..} <- maybeToList library
+            guard $ Set.member CabalLibraries toDiscover
+            Library{..} <- mconcat [maybeToList library, subLibraries]
             srcDir <- hsSourceDirs libBuildInfo
             exMod <- exposedModules
             pure Module
               { name = fromString $ mconcat $ intersperse "." $ Cabal.components exMod
-              , path = sourceDirToFilePath srcDir </> Cabal.toFilePath exMod <.> ".hs"
+              , path = ModuleFile $ sourceDirToFilePath srcDir </> Cabal.toFilePath exMod <.> ".hs"
+              }
+        , do
+            guard $ Set.member CabalExecutables toDiscover
+            Executable{..} <- executables
+            srcDir <- hsSourceDirs buildInfo
+            otherMod <- "Main" : buildInfo.otherModules
+            pure Module
+              { name = fromString $
+                if otherMod == "Main"
+                then unUnqualComponentName exeName ++ "-Main"
+                else mconcat $ intersperse "." $ Cabal.components otherMod
+              , path = ModuleFile $ sourceDirToFilePath srcDir </> Cabal.toFilePath otherMod <.> ".hs"
+              }
+        , do
+            guard $ Set.member CabalTests toDiscover
+            TestSuite{..} <- testSuites
+            srcDir <- hsSourceDirs testBuildInfo
+            otherMod <- testBuildInfo.otherModules
+            pure Module
+              { name = fromString $ mconcat $ intersperse "." $ Cabal.components otherMod
+              , path = ModuleFile $ sourceDirToFilePath srcDir </> Cabal.toFilePath otherMod <.> ".hs"
               }
-        ] -- TODO: exes + other-modules
+        ]
+
+  traverse validateModulePath candidateModules
+
+validateModulePath :: Module -> IO Module
+validateModulePath m = do
+  path <- case m.path of
+    ModuleFile fp -> do
+      fileExists <- doesFileExist fp
+      pure $ if fileExists then ModuleFile fp else ModuleNoFile
+    ModuleNoFile -> pure ModuleNoFile
+  pure Module {name = m.name, path = path}
+
+data CabalModuleType =
+  CabalLibraries
+  | CabalExecutables
+  | CabalTests
+  deriving stock (Show, Eq, Ord)
 
-  filterM (doesFileExist . (.path)) candidateModules
+data CabalDiscoverOpts = CabalDiscoverOpts
+  { toDiscover      :: Set CabalModuleType
+  , includeExternal :: Bool
+  } deriving stock (Show, Eq)
 
-discoverCabalModuleGraph :: IO ModuleGraph
-discoverCabalModuleGraph = do
+discoverCabalModuleGraph :: CabalDiscoverOpts -> IO ModuleGraph
+discoverCabalModuleGraph opts@CabalDiscoverOpts{..} = do
   fs <- getDirectoryContents "." -- XXX
-  mods <- fmap fold . traverse discoverCabalModules . filter ((".cabal" ==) . takeExtension) $ fs
+  mods <- fmap fold . traverse (discoverCabalModules opts) . filter ((".cabal" ==) . takeExtension) $ fs
 
   let modSet = foldMap (Set.singleton . name) mods
-  gs <- for mods $ \Module{..} -> do
-    internalImps <- filter (\Import{..} -> Set.member module_ modSet) <$> parseFileImports path
-    pure $ mkModuleGraph name $ fmap module_ internalImps
+  gs <- for mods $ \Module{..} -> case path of
+    ModuleFile modPath -> do
+      allImps <- parseFileImports modPath
+      let filteredImps =
+            if includeExternal
+            then allImps
+            else filter (\Import{..} -> Set.member module_ modSet) allImps
+      pure $ mkModuleGraph name $ fmap module_ filteredImps
+    ModuleNoFile -> pure $ mkModuleGraph name mempty
   pure $ fold gs

src/Graphex/Core.hs

@@ -6,7 +6,7 @@ import           Data.Map        (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Set        (Set)
 import qualified Data.Set        as Set
-import           Data.String     (IsString)
+import           Data.String     (IsString (..))
 import           Data.Text       (Text)
 
 data Graph a = Graph {
@@ -43,11 +43,17 @@ newtype ModuleName = ModuleName { unModuleName :: Text }
   deriving newtype (Eq, Ord, IsString)
   deriving stock (Show)
 
+data ModulePath = ModuleNoFile | ModuleFile FilePath
+  deriving stock (Eq, Ord, Show)
+
+instance IsString ModulePath where
+  fromString = ModuleFile
+
 data Module = Module
   { name :: ModuleName
-  , path :: FilePath
+  , path :: ModulePath
   }
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Ord)
 
 type ModuleGraph = Graph ModuleName
 

test/CabalSpec.hs

@@ -2,6 +2,7 @@
 module CabalSpec where
 
 import           Data.Foldable    (fold)
+import           Data.List        (sort)
 import qualified Data.Map.Strict  as Map
 import           Data.Maybe       (isJust)
 import qualified Data.Set         as Set
@@ -14,19 +15,55 @@ import           Graphex.Core
 
 import           TestInstances    ()
 
-myModules :: [Module]
-myModules = [Module "Graphex" "src/Graphex.hs",
-             Module "Graphex.Cabal" "src/Graphex/Cabal.hs",
-             Module "Graphex.Core" "src/Graphex/Core.hs",
-             Module "Graphex.CSV" "src/Graphex/CSV.hs",
-             Module "Graphex.LookingGlass" "src/Graphex/LookingGlass.hs",
-             Module "Graphex.Parser" "src/Graphex/Parser.hs",
-             Module "Graphex.Search" "src/Graphex/Search.hs"]
+libModules :: [Module]
+libModules =
+  [ Module "Graphex" "src/Graphex.hs"
+  , Module "Graphex.Cabal" "src/Graphex/Cabal.hs"
+  , Module "Graphex.Core" "src/Graphex/Core.hs"
+  , Module "Graphex.CSV" "src/Graphex/CSV.hs"
+  , Module "Graphex.LookingGlass" "src/Graphex/LookingGlass.hs"
+  , Module "Graphex.Parser" "src/Graphex/Parser.hs"
+  , Module "Graphex.Search" "src/Graphex/Search.hs"
+  ]
 
-unit_myCabalModules :: IO ()
-unit_myCabalModules = assertEqual "" myModules =<< discoverCabalModules "graphex.cabal"
+testModules :: [Module]
+testModules =
+  [ Module "CabalSpec" "test/CabalSpec.hs"
+  , Module "ImportParserSpec" "test/ImportParserSpec.hs"
+  , Module "Paths_graphex" ModuleNoFile
+  , Module "Spec"  "test/Spec.hs"
+  , Module "TestInstances"  "test/TestInstances.hs"
+  ]
+
+exeModules :: [Module]
+exeModules =
+  [ Module "Paths_graphex" ModuleNoFile
+  , Module "graphex-Main" "app/Main.hs"
+  ]
+
+
+mkDiscoverCabalModulesUnit :: [Module] -> CabalDiscoverOpts -> IO ()
+mkDiscoverCabalModulesUnit (sort -> mods) opts = assertEqual "" mods . sort =<< discoverCabalModules opts "graphex.cabal"
+
+unit_libCabalModules :: IO ()
+unit_libCabalModules = mkDiscoverCabalModulesUnit libModules CabalDiscoverOpts
+  { toDiscover = Set.singleton CabalLibraries
+  , includeExternal = False
+  }
+
+unit_exeCabalModules :: IO ()
+unit_exeCabalModules = mkDiscoverCabalModulesUnit exeModules CabalDiscoverOpts
+  { toDiscover = Set.singleton CabalExecutables
+  , includeExternal = False
+  }
+
+unit_testCabalModules :: IO ()
+unit_testCabalModules = mkDiscoverCabalModulesUnit testModules CabalDiscoverOpts
+  { toDiscover = Set.singleton CabalTests
+  , includeExternal = False
+  }
 
 unit_discoverModules :: IO ()
 unit_discoverModules = do
-    g <- discoverCabalModuleGraph
+    g <- discoverCabalModuleGraph CabalDiscoverOpts{toDiscover = Set.singleton CabalLibraries, includeExternal = False}
     assertBool (show g) . isJust $ why g "Graphex.Parser" "Graphex.Core"