{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Util.Scope (
Scope
,scopeCreate,scopeMatch,scopeMove
) where
import GHC.Hs
import SrcLoc
import BasicTypes
import Module
import FastString
import RdrName
import OccName
import GHC.Util.Module
import GHC.Util.RdrName
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Data.List.Extra
import Data.Maybe
newtype Scope = Scope [LImportDecl GhcPs]
deriving (Monoid, Semigroup)
instance Show Scope where
show (Scope x) = unsafePrettyPrint x
scopeCreate :: HsModule GhcPs -> Scope
scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res
where
pkg :: LImportDecl GhcPs -> Maybe StringLiteral
pkg (L _ x) = ideclPkgQual x
res :: [LImportDecl GhcPs]
res = [x | x <- hsmodImports xs , pkg x /= Just (StringLiteral NoSourceText (fsLit "hint"))]
prelude :: LImportDecl GhcPs
prelude = noLoc $ simpleImportDecl (mkModuleName "Prelude")
isPrelude :: LImportDecl GhcPs -> Bool
isPrelude (L _ x) = fromModuleName' (ideclName x) == "Prelude"
scopeMatch :: (Scope, Located RdrName) -> (Scope, Located RdrName) -> Bool
scopeMatch (a, x) (b, y)
| isSpecial' x && isSpecial' y = rdrNameStr' x == rdrNameStr' y
| isSpecial' x || isSpecial' y = False
| otherwise =
rdrNameStr' (unqual' x) == rdrNameStr' (unqual' y) && not (possModules a x `disjoint` possModules b y)
scopeMove :: (Scope, Located RdrName) -> Scope -> Located RdrName
scopeMove (a, x@(fromQual' -> Just name)) (Scope b) = case imps of
[] -> headDef x real
imp:_ | all (\x -> ideclQualified x /= NotQualified) imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name
| otherwise -> unqual' x
where
real :: [Located RdrName]
real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules a x]
imps :: [ImportDecl GhcPs]
imps = [unLoc i | r <- real, i <- b, possImport i r]
scopeMove (_, x) _ = x
possModules :: Scope -> Located RdrName -> [String]
possModules (Scope is) x = f x
where
res :: [String]
res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport i x]
f :: Located RdrName -> [String]
f n | isSpecial' n = [""]
f (L _ (Qual mod _)) = [moduleNameString mod | null res] ++ res
f _ = res
possImport :: LImportDecl GhcPs -> Located RdrName -> Bool
possImport i n | isSpecial' n = False
possImport (L _ i) (L _ (Qual mod x)) =
moduleNameString mod `elem` map fromModuleName' ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)
where ms = ideclName i : maybeToList (ideclAs i)
possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)
where
f :: (Bool, Located [LIE GhcPs]) -> Bool
f (hide, L _ xs) =
if hide then
Just True `notElem` ms
else
Nothing `elem` ms || Just True `elem` ms
where ms = map g xs
tag :: String
tag = occNameString x
g :: LIE GhcPs -> Maybe Bool
g (L _ (IEVar _ y)) = Just $ tag == unwrapName y
g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y
g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing
g (L _ (IEThingWith _ y _wildcard ys _fields)) = Just $ tag `elem` unwrapName y : map unwrapName ys
g _ = Just False
unwrapName :: LIEWrappedName RdrName -> String
unwrapName x = occNameString (rdrNameOcc $ ieWrappedName (unLoc x))
possImport _ _ = False