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

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

import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence

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

import Data.List.Extra
import Data.Maybe

-- A scope is a list of import declarations.
newtype Scope = Scope [LImportDecl GhcPs]
               deriving (Semigroup Scope
Scope
Semigroup Scope
-> Scope
-> (Scope -> Scope -> Scope)
-> ([Scope] -> Scope)
-> Monoid 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
$cp1Monoid :: Semigroup Scope
Monoid, b -> Scope -> Scope
NonEmpty Scope -> Scope
Scope -> Scope -> Scope
(Scope -> Scope -> Scope)
-> (NonEmpty Scope -> Scope)
-> (forall b. Integral b => b -> Scope -> Scope)
-> Semigroup 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 :: 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) = [LImportDecl GhcPs] -> String
forall a. Outputable a => a -> String
unsafePrettyPrint [LImportDecl GhcPs]
x

-- Create a 'Scope from a module's import declarations.
scopeCreate :: HsModule -> Scope
scopeCreate :: HsModule -> Scope
scopeCreate HsModule
xs = [LImportDecl GhcPs] -> Scope
Scope ([LImportDecl GhcPs] -> Scope) -> [LImportDecl GhcPs] -> Scope
forall a b. (a -> b) -> a -> b
$ [LImportDecl GhcPs
prelude | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LImportDecl GhcPs -> Bool) -> [LImportDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LImportDecl GhcPs -> Bool
isPrelude [LImportDecl GhcPs]
res] [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
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 SrcSpan
_ ImportDecl GhcPs
x) = ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
x

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

    -- Mock up an import declaraion corresponding to 'import Prelude'.
    prelude :: LImportDecl GhcPs
    prelude :: LImportDecl GhcPs
prelude = ImportDecl GhcPs -> LImportDecl GhcPs
forall e. e -> Located e
noLoc (ImportDecl GhcPs -> LImportDecl GhcPs)
-> ImportDecl GhcPs -> LImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ModuleName -> ImportDecl GhcPs
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl (String -> ModuleName
mkModuleName String
"Prelude")

    -- Predicate to test for a 'Prelude' import declaration.
    isPrelude :: LImportDecl GhcPs -> Bool
    isPrelude :: LImportDecl GhcPs -> Bool
isPrelude (L SrcSpan
_ ImportDecl GhcPs
x) = ModuleName -> String
moduleNameString (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName ImportDecl GhcPs
x)) String -> String -> Bool
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, Located RdrName) -> (Scope, Located RdrName) -> Bool
scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool
scopeMatch (Scope
a, Located RdrName
x) (Scope
b, Located RdrName
y)
  | Located RdrName -> Bool
isSpecial Located RdrName
x Bool -> Bool -> Bool
&& Located RdrName -> Bool
isSpecial Located RdrName
y = Located RdrName -> String
rdrNameStr Located RdrName
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Located RdrName -> String
rdrNameStr Located RdrName
y
  | Located RdrName -> Bool
isSpecial Located RdrName
x Bool -> Bool -> Bool
|| Located RdrName -> Bool
isSpecial Located RdrName
y = Bool
False
  | Bool
otherwise =
     Located RdrName -> String
rdrNameStr (Located RdrName -> Located RdrName
unqual Located RdrName
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Located RdrName -> String
rdrNameStr (Located RdrName -> Located RdrName
unqual Located RdrName
y) Bool -> Bool -> Bool
&& Bool -> Bool
not (Scope -> Located RdrName -> [ModuleName]
possModules Scope
a Located RdrName
x [ModuleName] -> [ModuleName] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`disjointOrd` Scope -> Located RdrName -> [ModuleName]
possModules Scope
b Located 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, Located RdrName) -> Scope -> Located RdrName
scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName
scopeMove (Scope
a, x :: Located RdrName
x@(Located RdrName -> Maybe OccName
fromQual -> Just OccName
name)) (Scope [LImportDecl GhcPs]
b) = case [ImportDecl GhcPs]
imps of
  [] -> Located RdrName -> [Located RdrName] -> Located RdrName
forall a. a -> [a] -> a
headDef Located RdrName
x [Located RdrName]
real
  ImportDecl GhcPs
imp:[ImportDecl GhcPs]
_ | (ImportDecl GhcPs -> Bool) -> [ImportDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ImportDecl GhcPs
x -> ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
x ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportDeclQualifiedStyle
NotQualified) [ImportDecl GhcPs]
imps -> RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
mkRdrQual (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> (Maybe (GenLocated SrcSpan ModuleName)
    -> GenLocated SrcSpan ModuleName)
-> Maybe (GenLocated SrcSpan ModuleName)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName
-> Maybe (GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a. a -> Maybe a -> a
fromMaybe (ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName ImportDecl GhcPs
imp) (Maybe (GenLocated SrcSpan ModuleName) -> ModuleName)
-> Maybe (GenLocated SrcSpan ModuleName) -> ModuleName
forall a b. (a -> b) -> a -> b
$ (ImportDecl GhcPs -> Maybe (GenLocated SrcSpan ModuleName))
-> [ImportDecl GhcPs] -> Maybe (GenLocated SrcSpan ModuleName)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust ImportDecl GhcPs -> Maybe (GenLocated SrcSpan ModuleName)
forall pass.
ImportDecl pass -> Maybe (GenLocated SrcSpan ModuleName)
ideclAs [ImportDecl GhcPs]
imps) OccName
name
        | Bool
otherwise -> Located RdrName -> Located RdrName
unqual Located RdrName
x
  where
    real :: [Located RdrName]
    real :: [Located RdrName]
real = [RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
m OccName
name | ModuleName
m <- Scope -> Located RdrName -> [ModuleName]
possModules Scope
a Located RdrName
x]

    imps :: [ImportDecl GhcPs]
    imps :: [ImportDecl GhcPs]
imps = [LImportDecl GhcPs -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc LImportDecl GhcPs
i | Located RdrName
r <- [Located RdrName]
real, LImportDecl GhcPs
i <- [LImportDecl GhcPs]
b, LImportDecl GhcPs -> Located RdrName -> Bool
possImport LImportDecl GhcPs
i Located RdrName
r]
scopeMove (Scope
_, Located RdrName
x) Scope
_ = Located 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.
possModules :: Scope -> Located RdrName -> [ModuleName]
possModules :: Scope -> Located RdrName -> [ModuleName]
possModules (Scope [LImportDecl GhcPs]
is) Located RdrName
x = Located RdrName -> [ModuleName]
f Located RdrName
x
  where
    res :: [ModuleName]
    res :: [ModuleName]
res = [GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenLocated SrcSpan ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName (ImportDecl GhcPs -> GenLocated SrcSpan ModuleName)
-> ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ LImportDecl GhcPs -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc LImportDecl GhcPs
i | LImportDecl GhcPs
i <- [LImportDecl GhcPs]
is, LImportDecl GhcPs -> Located RdrName -> Bool
possImport LImportDecl GhcPs
i Located RdrName
x]

    f :: Located RdrName -> [ModuleName]
    f :: Located RdrName -> [ModuleName]
f Located RdrName
n | Located RdrName -> Bool
isSpecial Located RdrName
n = [String -> ModuleName
mkModuleName String
""]
    f (L SrcSpan
_ (Qual ModuleName
mod OccName
_)) = [ModuleName
mod | [ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
res] [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
res
    f Located RdrName
_ = [ModuleName]
res

-- Determine if 'x' could possibly lie in the module named by the
-- import declaration 'i'.
possImport :: LImportDecl GhcPs -> Located RdrName -> Bool
possImport :: LImportDecl GhcPs -> Located RdrName -> Bool
possImport LImportDecl GhcPs
i Located RdrName
n | Located RdrName -> Bool
isSpecial Located RdrName
n = Bool
False
possImport (L SrcSpan
_ ImportDecl GhcPs
i) (L SrcSpan
_ (Qual ModuleName
mod OccName
x)) =
  ModuleName
mod ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
ms Bool -> Bool -> Bool
&& LImportDecl GhcPs -> Located RdrName -> Bool
possImport (ImportDecl GhcPs -> LImportDecl GhcPs
forall e. e -> Located e
noLoc ImportDecl GhcPs
i{ideclQualified :: ImportDeclQualifiedStyle
ideclQualified=ImportDeclQualifiedStyle
NotQualified}) (RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual OccName
x)
  where ms :: [ModuleName]
ms = (GenLocated SrcSpan ModuleName -> ModuleName)
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpan ModuleName] -> [ModuleName])
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> GenLocated SrcSpan ModuleName
forall pass. ImportDecl pass -> GenLocated SrcSpan ModuleName
ideclName ImportDecl GhcPs
i GenLocated SrcSpan ModuleName
-> [GenLocated SrcSpan ModuleName]
-> [GenLocated SrcSpan ModuleName]
forall a. a -> [a] -> [a]
: Maybe (GenLocated SrcSpan ModuleName)
-> [GenLocated SrcSpan ModuleName]
forall a. Maybe a -> [a]
maybeToList (ImportDecl GhcPs -> Maybe (GenLocated SrcSpan ModuleName)
forall pass.
ImportDecl pass -> Maybe (GenLocated SrcSpan ModuleName)
ideclAs ImportDecl GhcPs
i)
possImport (L SrcSpan
_ ImportDecl GhcPs
i) (L SrcSpan
_ (Unqual OccName
x)) = ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
i ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
NotQualified Bool -> Bool -> Bool
&& Bool
-> ((Bool, Located [LIE GhcPs]) -> Bool)
-> Maybe (Bool, Located [LIE GhcPs])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool, Located [LIE GhcPs]) -> Bool
f (ImportDecl GhcPs -> Maybe (Bool, Located [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl GhcPs
i)
  where
    f :: (Bool, Located [LIE GhcPs]) -> Bool
    f :: (Bool, Located [LIE GhcPs]) -> Bool
f (Bool
hide, L SrcSpan
_ [LIE GhcPs]
xs) =
      if Bool
hide then
        Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Bool]
ms
      else
        Maybe Bool
forall a. Maybe a
Nothing Maybe Bool -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Bool]
ms Bool -> Bool -> Bool
|| Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Bool]
ms
      where ms :: [Maybe Bool]
ms = (LIE GhcPs -> Maybe Bool) -> [LIE GhcPs] -> [Maybe Bool]
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 SrcSpan
_ (IEVar XIEVar GhcPs
_ LIEWrappedName (IdP GhcPs)
y)) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== LIEWrappedName RdrName -> String
unwrapName LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
y
    g (L SrcSpan
_ (IEThingAbs XIEThingAbs GhcPs
_ LIEWrappedName (IdP GhcPs)
y)) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== LIEWrappedName RdrName -> String
unwrapName LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
y
    g (L SrcSpan
_ (IEThingAll XIEThingAll GhcPs
_ LIEWrappedName (IdP GhcPs)
y)) = if String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== LIEWrappedName RdrName -> String
unwrapName LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
y then Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True else Maybe Bool
forall a. Maybe a
Nothing
    g (L SrcSpan
_ (IEThingWith XIEThingWith GhcPs
_ LIEWrappedName (IdP GhcPs)
y IEWildcard
_wildcard [LIEWrappedName (IdP GhcPs)]
ys [Located (FieldLbl (IdP GhcPs))]
_fields)) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ String
tag String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LIEWrappedName RdrName -> String
unwrapName LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (LIEWrappedName RdrName -> String)
-> [LIEWrappedName RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LIEWrappedName RdrName -> String
unwrapName [LIEWrappedName (IdP GhcPs)]
[LIEWrappedName RdrName]
ys
    g LIE GhcPs
_ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False

    unwrapName :: LIEWrappedName RdrName -> String
    unwrapName :: LIEWrappedName RdrName -> String
unwrapName LIEWrappedName RdrName
x = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc (RdrName -> OccName) -> RdrName -> OccName
forall a b. (a -> b) -> a -> b
$ IEWrappedName RdrName -> RdrName
forall name. IEWrappedName name -> name
ieWrappedName (LIEWrappedName RdrName -> IEWrappedName RdrName
forall l e. GenLocated l e -> e
unLoc LIEWrappedName RdrName
x))
possImport LImportDecl GhcPs
_ Located RdrName
_ = Bool
False