Build a resolution map along with creating a Package

src/Data/Abstract/Package.hs

@@ -22,6 +22,7 @@ data PackageBody term = PackageBody
   { packageModules     :: ModuleTable [Module term]
   , packagePrelude     :: Maybe (Module term)
   , packageEntryPoints :: ModuleTable (Maybe Name)
+  , packageResolutions :: Map.Map FilePath FilePath
   }
   deriving (Eq, Functor, Ord, Show)
 
@@ -33,8 +34,8 @@ data Package term = Package
   }
   deriving (Eq, Functor, Ord, Show)
 
-fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
-fromModules name version prelude entryPoints modules =
-  Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
+fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term
+fromModules name version prelude entryPoints modules resolutions =
+  Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints' resolutions)
   where
     entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules

src/Data/File.hs

@@ -16,6 +16,7 @@ data Project = Project
   , projectFiles :: [File]
   , projectLanguage :: Language
   , projectEntryPoints :: [File]
+  , projectExcludeDirs :: [FilePath]
   }
   deriving (Eq, Ord, Show)
 

src/Semantic/Graph.hs

@@ -25,7 +25,7 @@ import           Semantic.Task as Task
 
 data GraphType = ImportGraph | CallGraph
 
-graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry, Trace] effs
+graph :: Members '[Distribute WrappedTask, Files, Resolution, Task, Exc SomeException, Telemetry, Trace] effs
       => GraphType
       -> GraphRenderer output
       -> Project
@@ -61,7 +61,7 @@ graph graphType renderer project
           constrainingTypes = id
 
 -- | Parse a list of files into a 'Package'.
-parsePackage :: Members '[Distribute WrappedTask, Files, Task, Trace] effs
+parsePackage :: Members '[Distribute WrappedTask, Files, Resolution, Task, Trace] effs
              => Parser term -- ^ A parser.
              -> Maybe File  -- ^ Prelude (optional).
              -> Project     -- ^ Project to parse into a package.
@@ -69,7 +69,8 @@ parsePackage :: Members '[Distribute WrappedTask, Files, Task, Trace] effs
 parsePackage parser preludeFile project@Project{..} = do
   prelude <- traverse (parseModule parser Nothing) preludeFile
   p <- parseModules parser project
-  let pkg = Package.fromModules n Nothing prelude (length projectEntryPoints) p
+  resMap <- Task.resolutionMap project
+  let pkg = Package.fromModules n Nothing prelude (length projectEntryPoints) p resMap
   pkg <$ trace ("project: " <> show pkg)
 
   where

src/Semantic/IO.hs

@@ -99,7 +99,7 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do
       else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot)
 
   paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs
-  pure $ Project rootDir (toFile <$> paths) lang entryPoints
+  pure $ Project rootDir (toFile <$> paths) lang entryPoints excludeDirs
   where
     toFile path = File path (Just lang)
     exts = extensionsForLanguage lang

src/Semantic/Resolution.hs

@@ -14,29 +14,30 @@ import           Semantic.IO
 import           System.FilePath.Posix
 
 
-nodeJSResolutionMap :: Member Files effs => FilePath -> Language -> [FilePath] -> Eff effs (Map FilePath FilePath)
-nodeJSResolutionMap dir lang excludeDirs = do
-  files <- findFiles dir [".json"] excludeDirs -- ["node_modules"]
+nodeJSResolutionMap :: Member Files effs => FilePath -> Text -> [FilePath] -> Eff effs (Map FilePath FilePath)
+nodeJSResolutionMap dir prop excludeDirs = do
+  files <- findFiles dir [".json"] excludeDirs
   let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files
   blobs <- readBlobs (Right packageFiles)
-  pure $ fold (mapMaybe (lookup (propertyNameForLanguage lang)) blobs)
+  pure $ fold (mapMaybe (lookup prop) blobs)
   where
-    -- Entrypoint property name is different for JavaScript vs. TypeScript module resolution.
-    propertyNameForLanguage TypeScript = "types"
-    propertyNameForLanguage _ = "main"
-
     lookup :: Text -> Blob -> Maybe (Map FilePath FilePath)
     lookup k Blob{..} = decodeStrict (sourceBytes blobSource) >>= lookupProp blobPath k
 
     lookupProp :: FilePath -> Text -> Object -> Maybe (Map FilePath FilePath)
     lookupProp path k res = flip parseMaybe res $ \obj -> Map.singleton path <$> obj .: k
 
-nodeResolution :: Member Resolution effs => FilePath -> Language -> [FilePath] -> Eff effs (Map FilePath FilePath)
-nodeResolution dir prop = send . NodeJSResolution dir prop
+resolutionMap :: Member Resolution effs => Project -> Eff effs (Map FilePath FilePath)
+resolutionMap Project{..} = case projectLanguage of
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs)
+  JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)
+  _          -> send NoResolution
 
 data Resolution output where
-  NodeJSResolution :: FilePath -> Language -> [FilePath] -> Resolution (Map FilePath FilePath)
+  NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution (Map FilePath FilePath)
+  NoResolution :: Resolution (Map FilePath FilePath)
 
 runResolution :: Members '[Files] effs => Eff (Resolution ': effs) a -> Eff effs a
 runResolution = interpret $ \ res -> case res of
   NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
+  NoResolution -> pure Map.empty

src/Semantic/Task.hs

@@ -14,7 +14,8 @@ module Semantic.Task
 , IO.findFiles
 , IO.writeToOutput
 -- * Module Resolution
-, nodeResolution
+, resolutionMap
+, Resolution
 -- * Telemetry
 , writeLog
 , writeStat