-- 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.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

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

#if !MIN_VERSION_ghc(9,3,0)
import           Development.IDE.GHC.Compat.Util
#endif

#if MIN_VERSION_ghc(9,3,0)
import           GHC.Types.PkgQual
import           GHC.Unit.State
#endif

data Import
  = FileImport !ArtifactsLocation
  | PackageImport
  deriving (Int -> Import -> ShowS
[Import] -> ShowS
Import -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Import] -> ShowS
$cshowList :: [Import] -> ShowS
show :: Import -> String
$cshow :: Import -> String
showsPrec :: Int -> Import -> ShowS
$cshowsPrec :: Int -> Import -> ShowS
Show)

data ArtifactsLocation = ArtifactsLocation
  { ArtifactsLocation -> NormalizedFilePath
artifactFilePath    :: !NormalizedFilePath
  , ArtifactsLocation -> Maybe ModLocation
artifactModLocation :: !(Maybe ModLocation)
  , ArtifactsLocation -> Bool
artifactIsSource    :: !Bool          -- ^ True if a module is a source input
  , ArtifactsLocation -> Maybe Module
artifactModule      :: !(Maybe Module)
  } deriving Int -> ArtifactsLocation -> ShowS
[ArtifactsLocation] -> ShowS
ArtifactsLocation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArtifactsLocation] -> ShowS
$cshowList :: [ArtifactsLocation] -> ShowS
show :: ArtifactsLocation -> String
$cshow :: ArtifactsLocation -> String
showsPrec :: Int -> ArtifactsLocation -> ShowS
$cshowsPrec :: Int -> ArtifactsLocation -> ShowS
Show

instance NFData ArtifactsLocation where
  rnf :: ArtifactsLocation -> ()
rnf ArtifactsLocation{Bool
Maybe ModLocation
Maybe Module
NormalizedFilePath
artifactModule :: Maybe Module
artifactIsSource :: Bool
artifactModLocation :: Maybe ModLocation
artifactFilePath :: NormalizedFilePath
artifactModule :: ArtifactsLocation -> Maybe Module
artifactIsSource :: ArtifactsLocation -> Bool
artifactModLocation :: ArtifactsLocation -> Maybe ModLocation
artifactFilePath :: ArtifactsLocation -> NormalizedFilePath
..} = forall a. NFData a => a -> ()
rnf NormalizedFilePath
artifactFilePath seq :: forall a b. a -> b -> b
`seq` forall a. a -> ()
rwhnf Maybe ModLocation
artifactModLocation seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Bool
artifactIsSource seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe Module
artifactModule

isBootLocation :: ArtifactsLocation -> Bool
isBootLocation :: ArtifactsLocation -> Bool
isBootLocation = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactsLocation -> Bool
artifactIsSource

instance NFData Import where
  rnf :: Import -> ()
rnf (FileImport ArtifactsLocation
x) = forall a. NFData a => a -> ()
rnf ArtifactsLocation
x
  rnf Import
PackageImport  = ()

modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation NormalizedFilePath
nfp Maybe ModSummary
ms = NormalizedFilePath
-> Maybe ModLocation -> Bool -> Maybe Module -> ArtifactsLocation
ArtifactsLocation NormalizedFilePath
nfp (ModSummary -> ModLocation
ms_location forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModSummary
ms) Bool
source Maybe Module
mbMod
  where
    isSource :: HscSource -> Bool
isSource HscSource
HsSrcFile = Bool
True
    isSource HscSource
_         = Bool
False
    source :: Bool
source = case Maybe ModSummary
ms of
      Maybe ModSummary
Nothing     -> String
"-boot" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
      Just ModSummary
modSum -> HscSource -> Bool
isSource (ModSummary -> HscSource
ms_hsc_src ModSummary
modSum)
    mbMod :: Maybe Module
mbMod = ModSummary -> Module
ms_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModSummary
ms

-- | locate a module in the file system. Where we go from *daml to Haskell
locateModuleFile :: MonadIO m
             => [(UnitId, [FilePath])]
             -> [String]
             -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
             -> Bool
             -> ModuleName
             -> m (Maybe (UnitId, NormalizedFilePath))
locateModuleFile :: forall (m :: * -> *).
MonadIO m =>
[(UnitId, [String])]
-> [String]
-> (ModuleName
    -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> Bool
-> ModuleName
-> m (Maybe (UnitId, NormalizedFilePath))
locateModuleFile [(UnitId, [String])]
import_dirss [String]
exts ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)
targetFor Bool
isSource ModuleName
modName = do
  let candidates :: [String] -> [NormalizedFilePath]
candidates [String]
import_dirs =
        [ String -> NormalizedFilePath
toNormalizedFilePath' (String
prefix String -> ShowS
</> ModuleName -> String
moduleNameSlashes ModuleName
modName String -> ShowS
<.> ShowS
maybeBoot String
ext)
           | String
prefix <- [String]
import_dirs , String
ext <- [String]
exts]
  forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM forall {t}.
(t, NormalizedFilePath) -> m (Maybe (t, NormalizedFilePath))
go (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a b. (a -> b) -> [a] -> [b]
map (UnitId
uid,) ([String] -> [NormalizedFilePath]
candidates [String]
dirs) | (UnitId
uid, [String]
dirs) <- [(UnitId, [String])]
import_dirss])
  where
    go :: (t, NormalizedFilePath) -> m (Maybe (t, NormalizedFilePath))
go (t
uid, NormalizedFilePath
candidate) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t
uid,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall a b. (a -> b) -> a -> b
$ ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)
targetFor ModuleName
modName NormalizedFilePath
candidate
    maybeBoot :: ShowS
maybeBoot String
ext
      | Bool
isSource = String
ext forall a. [a] -> [a] -> [a]
++ String
"-boot"
      | Bool
otherwise = String
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.
#if MIN_VERSION_ghc(9,3,0)
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath])
mkImportDirs _env (i, flags) = Just (i, importPaths flags)
#else
mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath]))
mkImportDirs :: HscEnv
-> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [String]))
mkImportDirs HscEnv
env (UnitId
i, DynFlags
flags) = (, (UnitId
i, DynFlags -> [String]
importPaths DynFlags
flags)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> UnitId -> Maybe PackageName
getUnitName HscEnv
env UnitId
i
#endif

-- | 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
#if MIN_VERSION_ghc(9,3,0)
    -> PkgQual                -- ^ Package name
#else
    -> Maybe FastString                -- ^ Package name
#endif
    -> Bool                            -- ^ Is boot module
    -> m (Either [FileDiagnostic] Import)
locateModule :: forall (m :: * -> *).
MonadIO m =>
HscEnv
-> [(UnitId, DynFlags)]
-> [String]
-> (ModuleName
    -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> Located ModuleName
-> Maybe FastString
-> Bool
-> m (Either [FileDiagnostic] Import)
locateModule HscEnv
env [(UnitId, DynFlags)]
comp_info [String]
exts ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)
targetFor Located ModuleName
modName Maybe FastString
mbPkgName Bool
isSource = do
  case Maybe FastString
mbPkgName of
    -- "this" means that we should only look in the current package
#if MIN_VERSION_ghc(9,3,0)
    ThisPkg _ -> do
#else
    Just FastString
"this" -> do
#endif
      UnitId -> [String] -> m (Either [FileDiagnostic] Import)
lookupLocal (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (DynFlags -> [String]
importPaths DynFlags
dflags)
    -- if a package name is given we only go look for a package
#if MIN_VERSION_ghc(9,3,0)
    OtherPkg uid
      | Just dirs <- lookup uid import_paths
          -> lookupLocal uid dirs
#else
    Just FastString
pkgName
      | Just (UnitId
uid, [String]
dirs) <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FastString -> PackageName
PackageName FastString
pkgName) [(PackageName, (UnitId, [String]))]
import_paths
          -> UnitId -> [String] -> m (Either [FileDiagnostic] Import)
lookupLocal UnitId
uid [String]
dirs
#endif
      | Bool
otherwise -> m (Either [FileDiagnostic] Import)
lookupInPackageDB
#if MIN_VERSION_ghc(9,3,0)
    NoPkgQual -> do
#else
    Maybe FastString
Nothing -> do
#endif

      Maybe (UnitId, NormalizedFilePath)
mbFile <- forall (m :: * -> *).
MonadIO m =>
[(UnitId, [String])]
-> [String]
-> (ModuleName
    -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> Bool
-> ModuleName
-> m (Maybe (UnitId, NormalizedFilePath))
locateModuleFile ((DynFlags -> UnitId
homeUnitId_ DynFlags
dflags, DynFlags -> [String]
importPaths DynFlags
dflags) forall a. a -> [a] -> [a]
: [(UnitId, [String])]
other_imports) [String]
exts ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)
targetFor Bool
isSource forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName
      case Maybe (UnitId, NormalizedFilePath)
mbFile of
        Maybe (UnitId, NormalizedFilePath)
Nothing          -> m (Either [FileDiagnostic] Import)
lookupInPackageDB
        Just (UnitId
uid, NormalizedFilePath
file) -> forall {m :: * -> *} {a}.
MonadIO m =>
UnitId -> NormalizedFilePath -> m (Either a Import)
toModLocation UnitId
uid NormalizedFilePath
file
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
    import_paths :: [(PackageName, (UnitId, [String]))]
import_paths = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HscEnv
-> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [String]))
mkImportDirs HscEnv
env) [(UnitId, DynFlags)]
comp_info
    other_imports :: [(UnitId, [String])]
other_imports =
#if MIN_VERSION_ghc(9,4,0)
      -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units
      -- this one depends on
      -- This way if you have multiple units with the same module names, we won't get confused
      -- For example if unit a imports module M from unit B, when there is also a module M in unit C,
      -- and unit a only depends on unit b, without this logic there is the potential to get confused
      -- about which module unit a imports.
      -- Without multi-component support it is hard to recontruct the dependency environment so
      -- unit a will have both unit b and unit c in scope.
      map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
    ue = hsc_unit_env env
    units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue
    hpt_deps :: [UnitId]
    hpt_deps = homeUnitDepends units
#else
      [(UnitId, [String])]
_import_paths'
#endif

      -- 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.
    _import_paths' :: [(UnitId, [String])]
_import_paths' = -- import_paths' is only used in GHC < 9.4
#if MIN_VERSION_ghc(9,3,0)
            import_paths
#else
            forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, (UnitId, [String]))]
import_paths
#endif

    toModLocation :: UnitId -> NormalizedFilePath -> m (Either a Import)
toModLocation UnitId
uid NormalizedFilePath
file = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        ModLocation
loc <- DynFlags -> ModuleName -> String -> IO ModLocation
mkHomeModLocation DynFlags
dflags (forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName) (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
        let genMod :: Module
genMod = forall u. u -> ModuleName -> GenModule u
mkModule (forall uid. Definite uid -> GenUnit uid
RealUnit forall a b. (a -> b) -> a -> b
$ forall unit. unit -> Definite unit
Definite UnitId
uid) (forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName)  -- TODO support backpack holes
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ArtifactsLocation -> Import
FileImport forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> Maybe ModLocation -> Bool -> Maybe Module -> ArtifactsLocation
ArtifactsLocation NormalizedFilePath
file (forall a. a -> Maybe a
Just ModLocation
loc) (Bool -> Bool
not Bool
isSource) (forall a. a -> Maybe a
Just Module
genMod)

    lookupLocal :: UnitId -> [String] -> m (Either [FileDiagnostic] Import)
lookupLocal UnitId
uid [String]
dirs = do
      Maybe (UnitId, NormalizedFilePath)
mbFile <- forall (m :: * -> *).
MonadIO m =>
[(UnitId, [String])]
-> [String]
-> (ModuleName
    -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> Bool
-> ModuleName
-> m (Maybe (UnitId, NormalizedFilePath))
locateModuleFile [(UnitId
uid, [String]
dirs)] [String]
exts ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)
targetFor Bool
isSource forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName
      case Maybe (UnitId, NormalizedFilePath)
mbFile of
        Maybe (UnitId, NormalizedFilePath)
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]
notFoundErr HscEnv
env Located ModuleName
modName forall a b. (a -> b) -> a -> b
$ [ModuleSuggestion] -> LookupResult
LookupNotFound []
        Just (UnitId
uid', NormalizedFilePath
file) -> forall {m :: * -> *} {a}.
MonadIO m =>
UnitId -> NormalizedFilePath -> m (Either a Import)
toModLocation UnitId
uid' NormalizedFilePath
file

    lookupInPackageDB :: m (Either [FileDiagnostic] Import)
lookupInPackageDB = do
      case HscEnv -> ModuleName -> Maybe FastString -> LookupResult
Compat.lookupModuleWithSuggestions HscEnv
env (forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName) Maybe FastString
mbPkgName of
        LookupFound Module
_m (UnitInfo, ModuleOrigin)
_pkgConfig -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Import
PackageImport
        LookupResult
reason -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]
notFoundErr HscEnv
env Located ModuleName
modName LookupResult
reason

-- | Don't call this on a found module.
notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]
notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]
notFoundErr HscEnv
env Located ModuleName
modName LookupResult
reason =
  String -> [FileDiagnostic]
mkError' forall a b. (a -> b) -> a -> b
$ SDoc -> String
ppr' forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
env ModuleName
modName0 forall a b. (a -> b) -> a -> b
$ LookupResult -> FindResult
lookupToFindResult LookupResult
reason
  where
    dfs :: DynFlags
dfs = HscEnv -> DynFlags
hsc_dflags HscEnv
env
    mkError' :: String -> [FileDiagnostic]
mkError' = Text -> DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]
diagFromString Text
"not found" DiagnosticSeverity
DiagnosticSeverity_Error (forall a. HasSrcSpan a => a -> SrcSpan
Compat.getLoc Located ModuleName
modName)
    modName0 :: ModuleName
modName0 = forall l e. GenLocated l e -> e
unLoc Located ModuleName
modName
    ppr' :: SDoc -> String
ppr' = DynFlags -> SDoc -> String
showSDoc DynFlags
dfs
    -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer.
    lookupToFindResult :: LookupResult -> FindResult
lookupToFindResult =
      \case
        LookupFound Module
_m (UnitInfo, ModuleOrigin)
_pkgConfig ->
          forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Impossible: called lookupToFind on found module." (forall a. Outputable a => a -> SDoc
ppr ModuleName
modName0)
        LookupMultiple [(Module, ModuleOrigin)]
rs -> [(Module, ModuleOrigin)] -> FindResult
FoundMultiple [(Module, ModuleOrigin)]
rs
        LookupHidden [(Module, ModuleOrigin)]
pkg_hiddens [(Module, ModuleOrigin)]
mod_hiddens ->
          FindResult
notFound
             { fr_pkgs_hidden :: [GenUnit UnitId]
fr_pkgs_hidden = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> unit
moduleUnit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Module, ModuleOrigin)]
pkg_hiddens
             , fr_mods_hidden :: [GenUnit UnitId]
fr_mods_hidden = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> unit
moduleUnit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Module, ModuleOrigin)]
mod_hiddens
             }
        LookupUnusable [(Module, ModuleOrigin)]
unusable ->
          let unusables' :: [(GenUnit UnitId, UnusableUnitReason)]
unusables' = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (GenModule a, ModuleOrigin) -> (a, UnusableUnitReason)
get_unusable [(Module, ModuleOrigin)]
unusable
              get_unusable :: (GenModule a, ModuleOrigin) -> (a, UnusableUnitReason)
get_unusable (GenModule a
m, ModUnusable UnusableUnitReason
r) = (forall unit. GenModule unit -> unit
moduleUnit GenModule a
m, UnusableUnitReason
r)
              get_unusable (GenModule a
_, ModuleOrigin
r) =
                forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"findLookupResult: unexpected origin" (forall a. Outputable a => a -> SDoc
ppr ModuleOrigin
r)
           in FindResult
notFound {fr_unusables :: [(GenUnit UnitId, UnusableUnitReason)]
fr_unusables = [(GenUnit UnitId, UnusableUnitReason)]
unusables'}
        LookupNotFound [ModuleSuggestion]
suggest ->
          FindResult
notFound {fr_suggestions :: [ModuleSuggestion]
fr_suggestions = [ModuleSuggestion]
suggest}

notFound :: FindResult
notFound :: FindResult
notFound = NotFound
  { fr_paths :: [String]
fr_paths = []
  , fr_pkg :: Maybe (GenUnit UnitId)
fr_pkg = forall a. Maybe a
Nothing
  , fr_pkgs_hidden :: [GenUnit UnitId]
fr_pkgs_hidden = []
  , fr_mods_hidden :: [GenUnit UnitId]
fr_mods_hidden = []
  , fr_unusables :: [(GenUnit UnitId, UnusableUnitReason)]
fr_unusables = []
  , fr_suggestions :: [ModuleSuggestion]
fr_suggestions = []
  }