{-# Language ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Util.Scope (
   Scope
  ,scopeCreate,scopeMatch,scopeMove,possModules
) where

import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Data.FastString
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Types.PkgQual

import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable

import Data.List.Extra
import Data.Maybe
import Data.Bifunctor

-- A scope is a list of import declarations.
newtype Scope = Scope [LImportDecl GhcPs]
               deriving (Semigroup Scope
Scope
[Scope] -> Scope
Scope -> Scope -> Scope
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Scope] -> Scope
$cmconcat :: [Scope] -> Scope
mappend :: Scope -> Scope -> Scope
$cmappend :: Scope -> Scope -> Scope
mempty :: Scope
$cmempty :: Scope
Monoid, NonEmpty Scope -> Scope
Scope -> Scope -> Scope
forall b. Integral b => b -> Scope -> Scope
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Scope -> Scope
$cstimes :: forall b. Integral b => b -> Scope -> Scope
sconcat :: NonEmpty Scope -> Scope
$csconcat :: NonEmpty Scope -> Scope
<> :: Scope -> Scope -> Scope
$c<> :: Scope -> Scope -> Scope
Semigroup)

instance Show Scope where
    show :: Scope -> String
show (Scope [LImportDecl GhcPs]
x) = forall a. Outputable a => a -> String
unsafePrettyPrint [LImportDecl GhcPs]
x

-- Create a 'Scope from a module's import declarations.
scopeCreate :: HsModule GhcPs -> Scope
scopeCreate :: HsModule GhcPs -> Scope
scopeCreate HsModule GhcPs
xs = [LImportDecl GhcPs] -> Scope
Scope forall a b. (a -> b) -> a -> b
$ [LImportDecl GhcPs
prelude | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LImportDecl GhcPs -> Bool
isPrelude [LImportDecl GhcPs]
res] forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
res
  where
    -- Package qualifier of an import declaration.
    pkg :: LImportDecl GhcPs -> Maybe StringLiteral
    pkg :: LImportDecl GhcPs -> Maybe StringLiteral
pkg (L SrcSpanAnnA
_ ImportDecl GhcPs
x) =
      case forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
x of
        RawPkgQual StringLiteral
s -> forall a. a -> Maybe a
Just StringLiteral
s
        RawPkgQual
ImportDeclPkgQual GhcPs
NoRawPkgQual -> forall a. Maybe a
Nothing

    -- The import declarations contained by the module 'xs'.
    res :: [LImportDecl GhcPs]
    res :: [LImportDecl GhcPs]
res = [GenLocated SrcSpanAnnA (ImportDecl GhcPs)
x | GenLocated SrcSpanAnnA (ImportDecl GhcPs)
x <- forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
xs
             , LImportDecl GhcPs -> Maybe StringLiteral
pkg GenLocated SrcSpanAnnA (ImportDecl GhcPs)
x forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (SourceText -> FastString -> Maybe RealSrcSpan -> StringLiteral
StringLiteral SourceText
NoSourceText (String -> FastString
fsLit String
"hint") forall a. Maybe a
Nothing)
          ]

    -- Mock up an import declaration corresponding to 'import Prelude'.
    prelude :: LImportDecl GhcPs
    prelude :: LImportDecl GhcPs
prelude = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ModuleName -> ImportDecl GhcPs
simpleImportDecl (String -> ModuleName
mkModuleName String
"Prelude")

    -- Predicate to test for a 'Prelude' import declaration.
    isPrelude :: LImportDecl GhcPs -> Bool
    isPrelude :: LImportDecl GhcPs -> Bool
isPrelude (L SrcSpanAnnA
_ ImportDecl GhcPs
x) = ModuleName -> String
moduleNameString (forall l e. GenLocated l e -> e
unLoc (forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
x)) forall a. Eq a => a -> a -> Bool
== String
"Prelude"

-- Test if two names in two scopes may be referring to the same
-- thing. This is the case if the names are equal and (1) denote a
-- builtin type or data constructor or (2) the intersection of the
-- candidate modules where the two names arise is non-empty.
scopeMatch :: (Scope, LocatedN RdrName) -> (Scope, LocatedN RdrName) -> Bool
scopeMatch :: (Scope, GenLocated SrcSpanAnnN RdrName)
-> (Scope, GenLocated SrcSpanAnnN RdrName) -> Bool
scopeMatch (Scope
a, GenLocated SrcSpanAnnN RdrName
x) (Scope
b, GenLocated SrcSpanAnnN RdrName
y)
  | GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
x Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
y = GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr GenLocated SrcSpanAnnN RdrName
x forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr GenLocated SrcSpanAnnN RdrName
y
  | GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
x Bool -> Bool -> Bool
|| GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
y = Bool
False
  | Bool
otherwise =
     GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr (GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName
unqual GenLocated SrcSpanAnnN RdrName
x) forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr (GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName
unqual GenLocated SrcSpanAnnN RdrName
y) Bool -> Bool -> Bool
&& Bool -> Bool
not (Scope -> GenLocated SrcSpanAnnN RdrName -> [ModuleName]
possModules Scope
a GenLocated SrcSpanAnnN RdrName
x forall a. Ord a => [a] -> [a] -> Bool
`disjointOrd` Scope -> GenLocated SrcSpanAnnN RdrName -> [ModuleName]
possModules Scope
b GenLocated SrcSpanAnnN RdrName
y)

-- Given a name in a scope, and a new scope, create a name for the new
-- scope that will refer to the same thing. If the resulting name is
-- ambiguous, pick a plausible candidate.
scopeMove :: (Scope, LocatedN RdrName) -> Scope -> LocatedN RdrName
scopeMove :: (Scope, GenLocated SrcSpanAnnN RdrName)
-> Scope -> GenLocated SrcSpanAnnN RdrName
scopeMove (Scope
a, x :: GenLocated SrcSpanAnnN RdrName
x@(GenLocated SrcSpanAnnN RdrName -> Maybe OccName
fromQual -> Just OccName
name)) (Scope [LImportDecl GhcPs]
b) = case [ImportDecl GhcPs]
imps of
  [] | -- If `possModules a x` includes Prelude, but `b` does not contain any module that may import `x`,
       -- then unqualify `x` and assume that it is from Prelude (#1298).
       forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(L SrcSpanAnnN
_ RdrName
x) -> (ModuleName -> String
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RdrName -> Maybe (ModuleName, OccName)
isQual_maybe RdrName
x) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"Prelude") [GenLocated SrcSpanAnnN RdrName]
real -> GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName
unqual GenLocated SrcSpanAnnN RdrName
x
     | Bool
otherwise -> forall a. a -> [a] -> a
headDef GenLocated SrcSpanAnnN RdrName
x [GenLocated SrcSpanAnnN RdrName]
real
  ImportDecl GhcPs
imp:[ImportDecl GhcPs]
_ | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ImportDecl GhcPs
x -> forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
x forall a. Eq a => a -> a -> Bool
/= ImportDeclQualifiedStyle
NotQualified) [ImportDecl GhcPs]
imps -> forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
mkRdrQual (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
imp) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs [ImportDecl GhcPs]
imps) OccName
name
        | Bool
otherwise -> GenLocated SrcSpanAnnN RdrName -> GenLocated SrcSpanAnnN RdrName
unqual GenLocated SrcSpanAnnN RdrName
x
  where
    real :: [LocatedN RdrName]
    real :: [GenLocated SrcSpanAnnN RdrName]
real = [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
m OccName
name | ModuleName
m <- Scope -> GenLocated SrcSpanAnnN RdrName -> [ModuleName]
possModules Scope
a GenLocated SrcSpanAnnN RdrName
x]

    imps :: [ImportDecl GhcPs]
    imps :: [ImportDecl GhcPs]
imps = [forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i | GenLocated SrcSpanAnnN RdrName
r <- [GenLocated SrcSpanAnnN RdrName]
real, GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i <- [LImportDecl GhcPs]
b, LImportDecl GhcPs -> GenLocated SrcSpanAnnN RdrName -> IsImported
possImport GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i GenLocated SrcSpanAnnN RdrName
r forall a. Eq a => a -> a -> Bool
/= IsImported
NotImported]
scopeMove (Scope
_, GenLocated SrcSpanAnnN RdrName
x) Scope
_ = GenLocated SrcSpanAnnN RdrName
x

-- Calculate which modules a name could possibly lie in. If 'x' is
-- qualified but no imported element matches it, assume the user just
-- lacks an import.
-- 'prelude' is added to the result, unless we are certain which module a name is from (#1298).
possModules :: Scope -> LocatedN RdrName -> [ModuleName]
possModules :: Scope -> GenLocated SrcSpanAnnN RdrName -> [ModuleName]
possModules (Scope [LImportDecl GhcPs]
is) GenLocated SrcSpanAnnN RdrName
x =
    [ModuleName
prelude | ModuleName
prelude forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ModuleName, Bool)]
res, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> b
snd [(ModuleName, Bool)]
res)] forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(ModuleName, Bool)]
res
  where
    -- The 'Bool' signals whether we are certain that 'x' is imported from the module.
    res0, res :: [(ModuleName, Bool)]
    res0 :: [(ModuleName, Bool)]
res0 = [ (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i, IsImported
isImported forall a. Eq a => a -> a -> Bool
== IsImported
Imported)
           | GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i <- [LImportDecl GhcPs]
is, let isImported :: IsImported
isImported = LImportDecl GhcPs -> GenLocated SrcSpanAnnN RdrName -> IsImported
possImport GenLocated SrcSpanAnnA (ImportDecl GhcPs)
i GenLocated SrcSpanAnnN RdrName
x, IsImported
isImported forall a. Eq a => a -> a -> Bool
/= IsImported
NotImported ]

    res :: [(ModuleName, Bool)]
res | GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
x = [(String -> ModuleName
mkModuleName String
"", Bool
True)]
        | L SrcSpanAnnN
_ (Qual ModuleName
mod OccName
_) <- GenLocated SrcSpanAnnN RdrName
x = [(ModuleName
mod, Bool
True) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, Bool)]
res0] forall a. [a] -> [a] -> [a]
++ [(ModuleName, Bool)]
res0
        | Bool
otherwise = [(ModuleName, Bool)]
res0

    prelude :: ModuleName
prelude = String -> ModuleName
mkModuleName String
"Prelude"

data IsImported = Imported | PossiblyImported | NotImported  deriving (IsImported -> IsImported -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsImported -> IsImported -> Bool
$c/= :: IsImported -> IsImported -> Bool
== :: IsImported -> IsImported -> Bool
$c== :: IsImported -> IsImported -> Bool
Eq)

-- Determine if 'x' could possibly lie in the module named by the
-- import declaration 'i'.
possImport :: LImportDecl GhcPs -> LocatedN RdrName -> IsImported
possImport :: LImportDecl GhcPs -> GenLocated SrcSpanAnnN RdrName -> IsImported
possImport LImportDecl GhcPs
i GenLocated SrcSpanAnnN RdrName
n | GenLocated SrcSpanAnnN RdrName -> Bool
isSpecial GenLocated SrcSpanAnnN RdrName
n = IsImported
NotImported
possImport (L SrcSpanAnnA
_ ImportDecl GhcPs
i) (L SrcSpanAnnN
_ (Qual ModuleName
mod OccName
x)) =
  if ModuleName
mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
ms Bool -> Bool -> Bool
&& IsImported
NotImported forall a. Eq a => a -> a -> Bool
/= LImportDecl GhcPs -> GenLocated SrcSpanAnnN RdrName -> IsImported
possImport (forall a an. a -> LocatedAn an a
noLocA ImportDecl GhcPs
i{ideclQualified :: ImportDeclQualifiedStyle
ideclQualified=ImportDeclQualifiedStyle
NotQualified}) (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual OccName
x)
    then IsImported
Imported
    else IsImported
NotImported
  where ms :: [ModuleName]
ms = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList (forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs ImportDecl GhcPs
i)
possImport (L SrcSpanAnnA
_ ImportDecl GhcPs
i) (L SrcSpanAnnN
_ (Unqual OccName
x)) =
  if forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
i forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
NotQualified
    then forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsImported
PossiblyImported ((Bool, LocatedL [LIE GhcPs]) -> IsImported
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Eq a => a -> a -> Bool
== ImportListInterpretation
EverythingBut)) (forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList ImportDecl GhcPs
i)
    else IsImported
NotImported
  where
    f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported
    f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported
f (Bool
hide, L SrcSpanAnnL
_ [LIE GhcPs]
xs)
      | Bool
hide = if forall a. a -> Maybe a
Just Bool
True forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Bool]
ms then IsImported
NotImported else IsImported
PossiblyImported
      | forall a. a -> Maybe a
Just Bool
True forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Bool]
ms = IsImported
Imported
      | forall a. Maybe a
Nothing forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Bool]
ms = IsImported
PossiblyImported
      | Bool
otherwise = IsImported
NotImported
      where ms :: [Maybe Bool]
ms = forall a b. (a -> b) -> [a] -> [b]
map LIE GhcPs -> Maybe Bool
g [LIE GhcPs]
xs

    tag :: String
    tag :: String
tag = OccName -> String
occNameString OccName
x

    g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'?
    g :: LIE GhcPs -> Maybe Bool
g (L SrcSpanAnnA
_ (IEVar XIEVar GhcPs
_ LIEWrappedName GhcPs
y)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
tag forall a. Eq a => a -> a -> Bool
== LIEWrappedName GhcPs -> String
unwrapName LIEWrappedName GhcPs
y
    g (L SrcSpanAnnA
_ (IEThingAbs XIEThingAbs GhcPs
_ LIEWrappedName GhcPs
y)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
tag forall a. Eq a => a -> a -> Bool
== LIEWrappedName GhcPs -> String
unwrapName LIEWrappedName GhcPs
y
    g (L SrcSpanAnnA
_ (IEThingAll XIEThingAll GhcPs
_ LIEWrappedName GhcPs
y)) = if String
tag forall a. Eq a => a -> a -> Bool
== LIEWrappedName GhcPs -> String
unwrapName LIEWrappedName GhcPs
y then forall a. a -> Maybe a
Just Bool
True else forall a. Maybe a
Nothing
    g (L SrcSpanAnnA
_ (IEThingWith XIEThingWith GhcPs
_ LIEWrappedName GhcPs
y IEWildcard
_wildcard [LIEWrappedName GhcPs]
ys)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
tag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LIEWrappedName GhcPs -> String
unwrapName LIEWrappedName GhcPs
y forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map LIEWrappedName GhcPs -> String
unwrapName [LIEWrappedName GhcPs]
ys
    g LIE GhcPs
_ = forall a. a -> Maybe a
Just Bool
False

    unwrapName :: LIEWrappedName GhcPs -> String
    unwrapName :: LIEWrappedName GhcPs -> String
unwrapName LIEWrappedName GhcPs
x = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc forall a b. (a -> b) -> a -> b
$ forall (p :: Pass). IEWrappedName (GhcPass p) -> IdP (GhcPass p)
ieWrappedName (forall l e. GenLocated l e -> e
unLoc LIEWrappedName GhcPs
x))
possImport LImportDecl GhcPs
_ GenLocated SrcSpanAnnN RdrName
_ = IsImported
NotImported