FindImports.hs

-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP #-}

module Development.IDE.Import.FindImports
  ( locateModule
  , locateModuleFile
  , Import(..)
  , ArtifactsLocation(..)
  , modSummaryToArtifactsLocation
  , isBootLocation
  , mkImportDirs
  ) where

import           Control.DeepSeq
import           Development.IDE.GHC.Compat        as Compat
import           Development.IDE.GHC.Compat.Util
import           Development.IDE.GHC.Error         as ErrUtils
import           Development.IDE.GHC.Orphans       ()
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Location

-- standard imports
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Data.List                         (isSuffixOf)
import           Data.Maybe
import           System.FilePath

data Import
  = FileImport !ArtifactsLocation
  | PackageImport
  deriving (Show)

data ArtifactsLocation = ArtifactsLocation
  { artifactFilePath    :: !NormalizedFilePath
  , artifactModLocation :: !(Maybe ModLocation)
  , artifactIsSource    :: !Bool          -- ^ True if a module is a source input
  }
    deriving (Show)

instance NFData ArtifactsLocation where
  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource

isBootLocation :: ArtifactsLocation -> Bool
isBootLocation = not . artifactIsSource

instance NFData Import where
  rnf (FileImport x) = rnf x
  rnf PackageImport  = ()

modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source
  where
    isSource HsSrcFile = True
    isSource _         = False
    source = case ms of
      Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp
      Just ms -> isSource (ms_hsc_src ms)

-- | locate a module in the file system. Where we go from *daml to Haskell
locateModuleFile :: MonadIO m
             => [[FilePath]]
             -> [String]
             -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
             -> Bool
             -> ModuleName
             -> m (Maybe NormalizedFilePath)
locateModuleFile import_dirss exts targetFor isSource modName = do
  let candidates import_dirs =
        [ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext)
           | prefix <- import_dirs , ext <- exts]
  firstJustM (targetFor modName) (concatMap candidates import_dirss)
  where
    maybeBoot ext
      | isSource = ext ++ "-boot"
      | otherwise = ext

-- | This function is used to map a package name to a set of import paths.
-- It only returns Just for unit-ids which are possible to import into the
-- current module. In particular, it will return Nothing for 'main' components
-- as they can never be imported into another package.
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath])
mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i

-- | locate a module in either the file system or the package database. Where we go from *daml to
-- Haskell
locateModule
    :: MonadIO m
    => HscEnv
    -> [(UnitId, DynFlags)] -- ^ Import directories
    -> [String]                        -- ^ File extensions
    -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate
    -> Located ModuleName              -- ^ Module name
    -> Maybe FastString                -- ^ Package name
    -> Bool                            -- ^ Is boot module
    -> m (Either [FileDiagnostic] Import)
locateModule env comp_info exts targetFor modName mbPkgName isSource = do
  case mbPkgName of
    -- "this" means that we should only look in the current package
    Just "this" -> do
      lookupLocal [importPaths dflags]
    -- if a package name is given we only go look for a package
    Just pkgName
      | Just dirs <- lookup (PackageName pkgName) import_paths
          -> lookupLocal [dirs]
      | otherwise -> lookupInPackageDB env
    Nothing -> do
      -- first try to find the module as a file. If we can't find it try to find it in the package
      -- database.
      -- Here the importPaths for the current modules are added to the front of the import paths from the other components.
      -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
      -- each component will end up being found in the wrong place and cause a multi-cradle match failure.
      mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName
      case mbFile of
        Nothing   -> lookupInPackageDB env
        Just file -> toModLocation file
  where
    dflags = hsc_dflags env
    import_paths = mapMaybe (mkImportDirs env) comp_info
    toModLocation file = liftIO $ do
        loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)

    lookupLocal dirs = do
      mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName
      case mbFile of
        Nothing   -> return $ Left $ notFoundErr env modName $ LookupNotFound []
        Just file -> toModLocation file

    lookupInPackageDB env =
      case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of
        LookupFound _m _pkgConfig -> return $ Right PackageImport
        reason -> return $ Left $ notFoundErr env modName reason

-- | Don't call this on a found module.
notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]
notFoundErr env modName reason =
  mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason
  where
    dfs = hsc_dflags env
    mkError' = diagFromString "not found" DsError (Compat.getLoc modName)
    modName0 = unLoc modName
    ppr' = showSDoc dfs
    -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.
    lookupToFindResult =
      \case
        LookupFound _m _pkgConfig ->
          pprPanic "Impossible: called lookupToFind on found module." (ppr modName0)
        LookupMultiple rs -> FoundMultiple rs
        LookupHidden pkg_hiddens mod_hiddens ->
          notFound
             { fr_pkgs_hidden = map (moduleUnit . fst) pkg_hiddens
             , fr_mods_hidden = map (moduleUnit . fst) mod_hiddens
             }
        LookupUnusable unusable ->
          let unusables' = map get_unusable unusable
              get_unusable (m, ModUnusable r) = (moduleUnit m, r)
              get_unusable (_, r) =
                pprPanic "findLookupResult: unexpected origin" (ppr r)
           in notFound {fr_unusables = unusables'}
        LookupNotFound suggest ->
          notFound {fr_suggestions = suggest}

notFound :: FindResult
notFound = NotFound
  { fr_paths = []
  , fr_pkg = Nothing
  , fr_pkgs_hidden = []
  , fr_mods_hidden = []
  , fr_unusables = []
  , fr_suggestions = []
  }