{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Util.Scope (
Scope'
,scopeCreate',scopeImports',scopeMatch',scopeMove'
) where
import HsSyn
import SrcLoc
import BasicTypes
import Module
import FastString
import RdrName
import OccName
import GHC.Util.Module
import GHC.Util.RdrName
import Outputable
import Data.List
import Data.Maybe
newtype Scope' = Scope' [LImportDecl GhcPs]
deriving (Outputable, Monoid, Semigroup)
scopeCreate' :: HsModule GhcPs -> Scope'
scopeCreate' xs = Scope' $ [prelude | not $ any isPrelude res] ++ res
where
pkg :: LImportDecl GhcPs -> Maybe StringLiteral
pkg (LL _ x) = ideclPkgQual x
pkg _ = Nothing
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 (LL _ x) = fromModuleName' (ideclName x) == "Prelude"
isPrelude _ = False
scopeImports' :: Scope' -> [LImportDecl GhcPs]
scopeImports' (Scope' x) = x
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 (null $ possModules' a x `intersect` possModules' b y)
scopeMove' :: (Scope', Located RdrName) -> Scope' -> Located RdrName
scopeMove' (a, x@(fromQual' -> Just name)) (Scope' b)
| null imps = head $ real ++ [x]
| any (not . ideclQualified) imps = unqual' x
| otherwise = noLoc $ mkRdrQual (unLoc $ head (mapMaybe ideclAs imps ++ map ideclName imps)) name
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' (LL _ i) (L _ (Qual mod x)) =
moduleNameString mod `elem` map fromModuleName' ms && possImport' (noLoc i{ideclQualified=False}) (noLoc $ mkRdrUnqual x)
where ms = ideclName i : maybeToList (ideclAs i)
possImport' (LL _ i) (L _ (Unqual x)) = not (ideclQualified i) && 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