{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
module Agda.Syntax.Scope.Base where
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ( (<>), null )
#else
import Prelude hiding ( null )
#endif
import Control.Arrow (first, second, (***))
import Control.Applicative hiding (empty)
import Control.DeepSeq
import Control.Monad
import Data.Either (partitionEithers)
import Data.Function
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe
import Data.Data (Data)
import Agda.Benchmarking
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Fixity
import Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Concrete.Name as C
import qualified Agda.Syntax.Concrete as C
import Agda.Utils.AssocList (AssocList)
import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.NonemptyList
import Agda.Utils.Null
import Agda.Utils.Pretty
import qualified Agda.Utils.Map as Map
#include "undefined.h"
import Agda.Utils.Impossible
data Scope = Scope
{ scopeName :: A.ModuleName
, scopeParents :: [A.ModuleName]
, scopeNameSpaces :: ScopeNameSpaces
, scopeImports :: Map C.QName A.ModuleName
, scopeDatatypeModule :: Maybe DataOrRecord
}
deriving (Data, Eq, Show)
data NameSpaceId
= PrivateNS
| PublicNS
| ImportedNS
| OnlyQualifiedNS
deriving (Data, Eq, Bounded, Enum, Show)
type ScopeNameSpaces = [(NameSpaceId, NameSpace)]
localNameSpace :: Access -> NameSpaceId
localNameSpace PublicAccess = PublicNS
localNameSpace PrivateAccess{} = PrivateNS
localNameSpace OnlyQualified = OnlyQualifiedNS
nameSpaceAccess :: NameSpaceId -> Access
nameSpaceAccess PrivateNS = PrivateAccess Inserted
nameSpaceAccess _ = PublicAccess
scopeNameSpace :: NameSpaceId -> Scope -> NameSpace
scopeNameSpace ns = fromMaybe __IMPOSSIBLE__ . lookup ns . scopeNameSpaces
updateScopeNameSpaces :: (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope
updateScopeNameSpaces f s = s { scopeNameSpaces = f (scopeNameSpaces s) }
updateScopeNameSpacesM ::
(Functor m) => (ScopeNameSpaces -> m ScopeNameSpaces) -> Scope -> m Scope
updateScopeNameSpacesM f s = for (f $ scopeNameSpaces s) $ \ x ->
s { scopeNameSpaces = x }
data ScopeInfo = ScopeInfo
{ scopeCurrent :: A.ModuleName
, scopeModules :: Map A.ModuleName Scope
, scopeVarsToBind :: LocalVars
, scopeLocals :: LocalVars
, scopePrecedence :: PrecedenceStack
, scopeInverseName :: Map A.QName [C.QName]
, scopeInverseModule :: Map A.ModuleName [C.QName]
, scopeInScope :: InScopeSet
}
deriving (Data, Show)
instance Eq ScopeInfo where
ScopeInfo c1 m1 v1 l1 p1 _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ =
c1 == c2 && m1 == m2 && v1 == v2 && l1 == l2 && p1 == p2
type LocalVars = AssocList C.Name LocalVar
data Binder
= LambdaBound
| PatternBound
| LetBound
deriving (Data, Show, Eq)
data LocalVar = LocalVar
{ localVar :: A.Name
, localBinder :: Binder
, localShadowedBy :: [AbstractName]
}
deriving (Data, Show)
instance Eq LocalVar where
(==) = (==) `on` localVar
instance Ord LocalVar where
compare = compare `on` localVar
instance Pretty LocalVar where
pretty (LocalVar x _ []) = pretty x
pretty (LocalVar x _ xs) = text "." <> pretty x
shadowLocal :: [AbstractName] -> LocalVar -> LocalVar
shadowLocal [] _ = __IMPOSSIBLE__
shadowLocal ys (LocalVar x b zs) = LocalVar x b (ys ++ zs)
notShadowedLocal :: LocalVar -> Maybe A.Name
notShadowedLocal (LocalVar x _ []) = Just x
notShadowedLocal _ = Nothing
notShadowedLocals :: LocalVars -> AssocList C.Name A.Name
notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x
updateVarsToBind :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateVarsToBind f sc = sc { scopeVarsToBind = f (scopeVarsToBind sc) }
setVarsToBind :: LocalVars -> ScopeInfo -> ScopeInfo
setVarsToBind vars = updateVarsToBind (const vars)
updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateScopeLocals f sc = sc { scopeLocals = f (scopeLocals sc) }
setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo
setScopeLocals vars = updateScopeLocals (const vars)
mapScopeInfo :: (Scope -> Scope) -> ScopeInfo -> ScopeInfo
mapScopeInfo f i = i{ scopeModules = f <$> scopeModules i }
data NameSpace = NameSpace
{ nsNames :: NamesInScope
, nsModules :: ModulesInScope
, nsInScope :: InScopeSet
}
deriving (Data, Eq, Show)
type ThingsInScope a = Map C.Name [a]
type NamesInScope = ThingsInScope AbstractName
type ModulesInScope = ThingsInScope AbstractModule
type InScopeSet = Set A.QName
data InScopeTag a where
NameTag :: InScopeTag AbstractName
ModuleTag :: InScopeTag AbstractModule
class Eq a => InScope a where
inScopeTag :: InScopeTag a
instance InScope AbstractName where
inScopeTag = NameTag
instance InScope AbstractModule where
inScopeTag = ModuleTag
inNameSpace :: forall a. InScope a => NameSpace -> ThingsInScope a
inNameSpace = case inScopeTag :: InScopeTag a of
NameTag -> nsNames
ModuleTag -> nsModules
data KindOfName
= ConName
| FldName
| DefName
| PatternSynName
| MacroName
| QuotableName
deriving (Eq, Show, Data, Enum, Bounded)
allKindsOfNames :: [KindOfName]
allKindsOfNames = [minBound..maxBound]
data WhyInScope
= Defined
| Opened C.QName WhyInScope
| Applied C.QName WhyInScope
deriving (Data, Show)
data AbstractName = AbsName
{ anameName :: A.QName
, anameKind :: KindOfName
, anameLineage :: WhyInScope
}
deriving (Data, Show)
data AbstractModule = AbsModule
{ amodName :: A.ModuleName
, amodLineage :: WhyInScope
}
deriving (Data, Show)
instance Eq AbstractName where
(==) = (==) `on` anameName
instance Ord AbstractName where
compare = compare `on` anameName
lensAnameName :: Functor m => (A.QName -> m A.QName) -> AbstractName -> m AbstractName
lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }
instance Eq AbstractModule where
(==) = (==) `on` amodName
instance Ord AbstractModule where
compare = compare `on` amodName
lensAmodName :: Functor m => (A.ModuleName -> m A.ModuleName) -> AbstractModule -> m AbstractModule
lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }
data ResolvedName
=
VarName
{ resolvedVar :: A.Name
, resolvedBinder :: Binder
}
|
DefinedName Access AbstractName
|
FieldName (NonemptyList AbstractName)
|
ConstructorName (NonemptyList AbstractName)
|
PatternSynResName (NonemptyList AbstractName)
|
UnknownName
deriving (Data, Show, Eq)
instance Pretty ResolvedName where
pretty = \case
VarName x _ -> text "variable" <+> pretty x
DefinedName a x -> pretty a <+> pretty x
FieldName xs -> text "field" <+> pretty xs
ConstructorName xs -> text "constructor" <+> pretty xs
PatternSynResName x -> text "pattern" <+> pretty x
UnknownName -> text "<unknown name>"
mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a
mergeNames = Map.unionWith List.union
emptyNameSpace :: NameSpace
emptyNameSpace = NameSpace Map.empty Map.empty Set.empty
mapNameSpace :: (NamesInScope -> NamesInScope ) ->
(ModulesInScope -> ModulesInScope) ->
(InScopeSet -> InScopeSet ) ->
NameSpace -> NameSpace
mapNameSpace fd fm fs ns =
ns { nsNames = fd $ nsNames ns
, nsModules = fm $ nsModules ns
, nsInScope = fs $ nsInScope ns
}
zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope ) ->
(ModulesInScope -> ModulesInScope -> ModulesInScope) ->
(InScopeSet -> InScopeSet -> InScopeSet ) ->
NameSpace -> NameSpace -> NameSpace
zipNameSpace fd fm fs ns1 ns2 =
ns1 { nsNames = nsNames ns1 `fd` nsNames ns2
, nsModules = nsModules ns1 `fm` nsModules ns2
, nsInScope = nsInScope ns1 `fs` nsInScope ns2
}
mapNameSpaceM :: Applicative m =>
(NamesInScope -> m NamesInScope ) ->
(ModulesInScope -> m ModulesInScope) ->
(InScopeSet -> m InScopeSet ) ->
NameSpace -> m NameSpace
mapNameSpaceM fd fm fs ns = update ns <$> fd (nsNames ns) <*> fm (nsModules ns) <*> fs (nsInScope ns)
where
update ns ds ms is = ns { nsNames = ds, nsModules = ms, nsInScope = is }
emptyScope :: Scope
emptyScope = Scope
{ scopeName = noModuleName
, scopeParents = []
, scopeNameSpaces = [ (nsid, emptyNameSpace) | nsid <- [minBound..maxBound] ]
, scopeImports = Map.empty
, scopeDatatypeModule = Nothing
}
emptyScopeInfo :: ScopeInfo
emptyScopeInfo = ScopeInfo
{ scopeCurrent = noModuleName
, scopeModules = Map.singleton noModuleName emptyScope
, scopeVarsToBind = []
, scopeLocals = []
, scopePrecedence = []
, scopeInverseName = Map.empty
, scopeInverseModule = Map.empty
, scopeInScope = Set.empty
}
mapScope :: (NameSpaceId -> NamesInScope -> NamesInScope ) ->
(NameSpaceId -> ModulesInScope -> ModulesInScope) ->
(NameSpaceId -> InScopeSet -> InScopeSet ) ->
Scope -> Scope
mapScope fd fm fs = updateScopeNameSpaces $ AssocList.mapWithKey mapNS
where
mapNS acc = mapNameSpace (fd acc) (fm acc) (fs acc)
mapScope_ :: (NamesInScope -> NamesInScope ) ->
(ModulesInScope -> ModulesInScope) ->
(InScopeSet -> InScopeSet ) ->
Scope -> Scope
mapScope_ fd fm fs = mapScope (const fd) (const fm) (const fs)
mapScope' :: NameSpaceId -> (NamesInScope -> NamesInScope ) ->
(ModulesInScope -> ModulesInScope) ->
(InScopeSet -> InScopeSet ) ->
Scope -> Scope
mapScope' i fd fm fs = mapScope (\ j -> if i == j then fd else id)
(\ j -> if i == j then fm else id)
(\ j -> if i == j then fs else id)
mapScopeM :: Applicative m =>
(NameSpaceId -> NamesInScope -> m NamesInScope ) ->
(NameSpaceId -> ModulesInScope -> m ModulesInScope) ->
(NameSpaceId -> InScopeSet -> m InScopeSet ) ->
Scope -> m Scope
mapScopeM fd fm fs = updateScopeNameSpacesM $ AssocList.mapWithKeyM mapNS
where
mapNS acc = mapNameSpaceM (fd acc) (fm acc) (fs acc)
mapScopeM_ :: Applicative m =>
(NamesInScope -> m NamesInScope ) ->
(ModulesInScope -> m ModulesInScope) ->
(InScopeSet -> m InScopeSet ) ->
Scope -> m Scope
mapScopeM_ fd fm fs = mapScopeM (const fd) (const fm) (const fs)
zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope ) ->
(NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->
(NameSpaceId -> InScopeSet -> InScopeSet -> InScopeSet ) ->
Scope -> Scope -> Scope
zipScope fd fm fs s1 s2 =
s1 { scopeNameSpaces =
[ (nsid, zipNS nsid ns1 ns2)
| ((nsid, ns1), (nsid', ns2)) <-
fromMaybe __IMPOSSIBLE__ $
zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2)
, assert (nsid == nsid')
]
, scopeImports = (Map.union `on` scopeImports) s1 s2
}
where
assert True = True
assert False = __IMPOSSIBLE__
zipNS acc = zipNameSpace (fd acc) (fm acc) (fs acc)
zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope ) ->
(ModulesInScope -> ModulesInScope -> ModulesInScope) ->
(InScopeSet -> InScopeSet -> InScopeSet ) ->
Scope -> Scope -> Scope
zipScope_ fd fm fs = zipScope (const fd) (const fm) (const fs)
recomputeInScopeSets :: Scope -> Scope
recomputeInScopeSets = updateScopeNameSpaces (map $ second recomputeInScope)
where
recomputeInScope ns = ns { nsInScope = Set.unions $ map (Set.fromList . map anameName)
$ Map.elems $ nsNames ns }
filterScope :: (C.Name -> Bool) -> (C.Name -> Bool) -> Scope -> Scope
filterScope pd pm = recomputeInScopeSets . mapScope_ (Map.filterKeys pd) (Map.filterKeys pm) id
allNamesInScope :: InScope a => Scope -> ThingsInScope a
allNamesInScope = namesInScope [minBound..maxBound]
allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access)
allNamesInScope' s =
foldr1 mergeNames [ map (, nameSpaceAccess ns) <$> namesInScope [ns] s
| ns <- [minBound..maxBound] ]
exportedNamesInScope :: InScope a => Scope -> ThingsInScope a
exportedNamesInScope = namesInScope [PublicNS, ImportedNS, OnlyQualifiedNS]
namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a
namesInScope ids s =
foldr1 mergeNames [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ]
allThingsInScope :: Scope -> NameSpace
allThingsInScope = thingsInScope [minBound..maxBound]
thingsInScope :: [NameSpaceId] -> Scope -> NameSpace
thingsInScope fs s =
NameSpace { nsNames = namesInScope fs s
, nsModules = namesInScope fs s
, nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ]
}
mergeScope :: Scope -> Scope -> Scope
mergeScope = zipScope_ mergeNames mergeNames Set.union
mergeScopes :: [Scope] -> Scope
mergeScopes [] = __IMPOSSIBLE__
mergeScopes ss = foldr1 mergeScope ss
setScopeAccess :: NameSpaceId -> Scope -> Scope
setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns
where
zero = emptyNameSpace
one = allThingsInScope s
imp = thingsInScope [ImportedNS] s
noimp = thingsInScope [PublicNS, PrivateNS, OnlyQualifiedNS] s
ns b = case (a, b) of
(PublicNS, PublicNS) -> noimp
(PublicNS, ImportedNS) -> imp
_ | a == b -> one
| otherwise -> zero
setNameSpace :: NameSpaceId -> NameSpace -> Scope -> Scope
setNameSpace nsid ns = modifyNameSpace nsid $ const ns
modifyNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> Scope -> Scope
modifyNameSpace nsid f = updateScopeNameSpaces $ AssocList.updateAt nsid f
addNamesToScope :: NameSpaceId -> C.Name -> [AbstractName] -> Scope -> Scope
addNamesToScope acc x ys s = mergeScope s s1
where
s1 = setScopeAccess acc $ setNameSpace PublicNS ns emptyScope
ns = emptyNameSpace { nsNames = Map.singleton x ys
, nsInScope = Set.fromList (map anameName ys) }
addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope
addNameToScope acc x y s = addNamesToScope acc x [y] s
removeNameFromScope :: NameSpaceId -> C.Name -> Scope -> Scope
removeNameFromScope ns x s = mapScope remove (const id) (const id) s
where
remove ns' | ns' /= ns = id
| otherwise = Map.delete x
addModuleToScope :: NameSpaceId -> C.Name -> AbstractModule -> Scope -> Scope
addModuleToScope acc x m s = mergeScope s s1
where
s1 = setScopeAccess acc $ setNameSpace PublicNS ns emptyScope
ns = emptyNameSpace { nsModules = Map.singleton x [m] }
type UsingOrHiding = Either C.Using [C.ImportedName]
usingOrHiding :: C.ImportDirective -> UsingOrHiding
usingOrHiding i =
case (using i, hiding i) of
(UseEverything, xs) -> Right xs
(u, []) -> Left u
_ -> __IMPOSSIBLE__
applyImportDirective :: C.ImportDirective -> Scope -> Scope
applyImportDirective dir s = mergeScope usedOrHidden renamed
where
usedOrHidden = useOrHide (hideLHS (impRenaming dir) $ usingOrHiding dir) s
renamed = rename (impRenaming dir) $ useOrHide useRenamedThings s
useRenamedThings = Left $ Using $ map renFrom $ impRenaming dir
hideLHS :: [C.Renaming] -> UsingOrHiding -> UsingOrHiding
hideLHS _ i@(Left _) = i
hideLHS ren (Right xs) = Right $ xs ++ map renFrom ren
useOrHide :: UsingOrHiding -> Scope -> Scope
useOrHide (Right xs) s = filterNames notElem notElem xs s
useOrHide (Left (Using xs)) s = filterNames elem elem xs s
useOrHide _ _ = __IMPOSSIBLE__
filterNames :: (C.Name -> [C.Name] -> Bool) ->
(C.Name -> [C.Name] -> Bool) ->
[C.ImportedName] -> Scope -> Scope
filterNames pd pm xs = filterScope (`pd` ds) (`pm` ms)
where
ds = [ x | ImportedName x <- xs ]
ms = [ m | ImportedModule m <- xs ]
rename :: [C.Renaming] -> Scope -> Scope
rename rho = mapScope_ (Map.mapKeys $ ren drho)
(Map.mapKeys $ ren mrho)
id
where
(drho, mrho) = partitionEithers $ for rho $ \case
Renaming (ImportedName x) (ImportedName y) _ -> Left (x,y)
Renaming (ImportedModule x) (ImportedModule y) _ -> Right (x,y)
_ -> __IMPOSSIBLE__
ren r x = fromMaybe x $ lookup x r
renameCanonicalNames :: Map A.QName A.QName -> Map A.ModuleName A.ModuleName ->
Scope -> Scope
renameCanonicalNames renD renM = mapScope_ renameD renameM (Set.map newName)
where
newName x = Map.findWithDefault x x renD
newMod x = Map.findWithDefault x x renM
renameD = Map.map $ map $ over lensAnameName newName
renameM = Map.map $ map $ over lensAmodName newMod
restrictPrivate :: Scope -> Scope
restrictPrivate s = setNameSpace PrivateNS emptyNameSpace
$ s { scopeImports = Map.empty }
restrictLocalPrivate :: ModuleName -> Scope -> Scope
restrictLocalPrivate m = mapScope' PrivateNS (Map.mapMaybe rName) (Map.mapMaybe rMod)
(Set.filter (not . (`isInModule` m)))
where
check p x = x <$ guard (p x)
rName as = check (not . null) $ filter (not . (`isInModule` m) . anameName) as
rMod as = check (not . null) $ filter (not . (`isSubModuleOf` m) . amodName) as
removeOnlyQualified :: Scope -> Scope
removeOnlyQualified s = setNameSpace OnlyQualifiedNS emptyNameSpace s
inScopeBecause :: (WhyInScope -> WhyInScope) -> Scope -> Scope
inScopeBecause f = mapScope_ mapName mapMod id
where
mapName = fmap . map $ \a -> a { anameLineage = f $ anameLineage a }
mapMod = fmap . map $ \a -> a { amodLineage = f $ amodLineage a }
publicModules :: ScopeInfo -> Map A.ModuleName Scope
publicModules scope = Map.filterWithKey (\ m _ -> reachable m) allMods
where
allMods = Map.map restrictPrivate $ scopeModules scope
root = scopeCurrent scope
modules s = map amodName $ concat $ Map.elems $ allNamesInScope s
chase m = m : concatMap chase ms
where ms = maybe __IMPOSSIBLE__ modules $ Map.lookup m allMods
reachable = (`elem` chase root)
publicNames :: ScopeInfo -> Set AbstractName
publicNames scope =
Set.fromList $ concat $ Map.elems $
exportedNamesInScope $ mergeScopes $ Map.elems $ publicModules scope
everythingInScope :: ScopeInfo -> NameSpace
everythingInScope scope = allThingsInScope $ mergeScopes $
(s0 :) $ map look $ scopeParents s0
where
look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
s0 = look $ scopeCurrent scope
flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName]
flattenScope ms scope =
Map.unionWith (++)
(build ms allNamesInScope root)
imported
where
current = moduleScope $ scopeCurrent scope
root = mergeScopes $ current : map moduleScope (scopeParents current)
imported = Map.unionsWith (++)
[ qual c (build ms' exportedNamesInScope $ moduleScope a)
| (c, a) <- Map.toList $ scopeImports root
, let
ms' = mapMaybe (List.stripPrefix $ C.qnameParts c) ms
, not $ null ms' ]
qual c = Map.mapKeys (q c)
where
q (C.QName x) = C.Qual x
q (C.Qual m x) = C.Qual m . q x
build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName]
build ms getNames s = Map.unionsWith (++) $
(Map.mapKeysMonotonic C.QName $ getNames s) :
[ Map.mapKeysMonotonic (\ y -> C.Qual x y) $
build ms' exportedNamesInScope $ moduleScope m
| (x, mods) <- Map.toList (getNames s)
, let ms' = [ tl | hd:tl <- ms, hd == x ]
, not $ null ms'
, AbsModule m _ <- mods ]
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
concreteNamesInScope :: ScopeInfo -> Set C.QName
concreteNamesInScope scope =
Set.unions [ build allNamesInScope root, imported, locals ]
where
current = moduleScope $ scopeCurrent scope
root = mergeScopes $ current : map moduleScope (scopeParents current)
locals = Set.fromList [ C.QName x | (x, _) <- scopeLocals scope ]
imported = Set.unions
[ qual c (build exportedNamesInScope $ moduleScope a)
| (c, a) <- Map.toList $ scopeImports root ]
qual c = Set.map (q c)
where
q (C.QName x) = C.Qual x
q (C.Qual m x) = C.Qual m . q x
build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName
build getNames s = Set.unions $
(Set.fromList $ map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) :
[ Set.mapMonotonic (\ y -> C.Qual x y) $
build exportedNamesInScope $ moduleScope m
| (x, mods) <- Map.toList (getNames s)
, prettyShow x /= "_"
, AbsModule m _ <- mods ]
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a]
scopeLookup q scope = map fst $ scopeLookup' q scope
scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]
scopeLookup' q scope =
List.nubBy ((==) `on` fst) $
findName q root ++ maybeToList topImports ++ imports
where
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
current :: Scope
current = moduleScope $ scopeCurrent scope
root :: Scope
root = mergeScopes $ current : map moduleScope (scopeParents current)
findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]
findName q0 s = case q0 of
C.QName x -> lookupName x s
C.Qual x q -> do
let
mods :: [A.ModuleName]
mods = amodName . fst <$> lookupName x s
defs :: [A.ModuleName]
defs = mnameFromList . qnameToList . anameName . fst <$> lookupName x s
m <- mods
let ss = Map.lookup m $ scopeModules scope
ss' = restrictPrivate <$> ss
s' <- maybeToList ss'
findName q s'
where
lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)]
lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s
topImports :: Maybe (a, Access)
topImports = case (inScopeTag :: InScopeTag a) of
NameTag -> Nothing
ModuleTag -> first (`AbsModule` Defined) <$> imported q
imported :: C.QName -> Maybe (A.ModuleName, Access)
imported q = fmap (,PublicAccess) $ Map.lookup q $ scopeImports root
imports :: [(a, Access)]
imports = do
(m, x) <- splitName q
m <- maybeToList $ fst <$> imported m
findName x $ restrictPrivate $ moduleScope m
splitName :: C.QName -> [(C.QName, C.QName)]
splitName (C.QName x) = []
splitName (C.Qual x q) =
(C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ]
data AllowAmbiguousNames
= AmbiguousAnything
| AmbiguousConProjs
| AmbiguousNothing
deriving (Eq)
isNameInScope :: A.QName -> ScopeInfo -> Bool
isNameInScope q scope =
billToPure [ Scoping, InverseScopeLookup ] $
Set.member q (scopeInScope scope)
inverseScopeLookup :: Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]
inverseScopeLookup = inverseScopeLookup' AmbiguousConProjs
inverseScopeLookup' :: AllowAmbiguousNames -> Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]
inverseScopeLookup' amb name scope = billToPure [ Scoping , InverseScopeLookup ] $
case name of
Left m -> best $ filter unambiguousModule $ findModule m
Right q -> best $ filter unambiguousName $ findName q
where
findName x = fromMaybe [] $ Map.lookup x (scopeInverseName scope)
findModule x = fromMaybe [] $ Map.lookup x (scopeInverseModule scope)
len :: C.QName -> Int
len (C.QName _) = 1
len (C.Qual _ x) = 1 + len x
best :: [C.QName] -> [C.QName]
best = List.sortBy (compare `on` len)
unique :: forall a . [a] -> Bool
unique [] = __IMPOSSIBLE__
unique [_] = True
unique (_:_:_) = False
unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule])
unambiguousName q = amb == AmbiguousAnything
|| unique xs
|| amb == AmbiguousConProjs
&& or [ all ((kind ==) . anameKind) xs | kind <- [ConName, FldName, PatternSynName] ]
where xs = scopeLookup q scope
recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo
recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $
scope { scopeInverseName = nameMap
, scopeInverseModule = Map.fromList [ (x, findModule x) | x <- Map.keys moduleMap ++ Map.keys importMap ]
, scopeInScope = Set.unions $ map (scopeSet . snd) scopes
}
where
this = scopeCurrent scope
current = this : scopeParents (moduleScope this)
scopes = [ (m, restrict m s) | (m, s) <- Map.toList (scopeModules scope) ]
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
restrict m s | m `elem` current = s
| otherwise = restrictPrivate s
scopeSet s = Set.unions $ map (namespaceSet . snd) $ scopeNameSpaces s
namespaceSet s = nsInScope s
internalName :: C.QName -> Bool
internalName C.QName{} = False
internalName (C.Qual m n) = intern m || internalName n
where
intern (C.Name _ [ C.Id ('.' : '#' : _) ]) = True
intern _ = False
findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]
findName table q = do
(m, x) <- fromMaybe [] $ Map.lookup q table
if m `elem` current
then return (C.QName x)
else do
y <- findModule m
let z = C.qualify y x
guard $ not $ internalName z
return z
findModule :: A.ModuleName -> [C.QName]
findModule q = findName moduleMap q ++
fromMaybe [] (Map.lookup q importMap)
importMap = Map.fromListWith (++) $ do
(m, s) <- scopes
(x, y) <- Map.toList $ scopeImports s
return (y, [x])
moduleMap = Map.fromListWith (++) $ do
(m, s) <- scopes
(x, ms) <- Map.toList (allNamesInScope s)
q <- amodName <$> ms
return (q, [(m, x)])
nameMap = Map.fromListWith (++) $ do
(m, s) <- scopes
(x, ms) <- Map.toList (allNamesInScope s)
q <- anameName <$> ms
if elem m current
then return (q, [C.QName x])
else do
y <- findModule m
let z = C.qualify y x
guard $ not $ internalName z
return (q, [z])
inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName]
inverseScopeLookupName x = inverseScopeLookup (Right x)
inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName]
inverseScopeLookupName' ambCon x = inverseScopeLookup' ambCon (Right x)
inverseScopeLookupModule :: A.ModuleName -> ScopeInfo -> [C.QName]
inverseScopeLookupModule x = inverseScopeLookup (Left x)
instance Pretty AbstractName where
pretty = pretty . anameName
instance Pretty AbstractModule where
pretty = pretty . amodName
instance Pretty NameSpaceId where
pretty = text . \case
PublicNS -> "public"
PrivateNS -> "private"
ImportedNS -> "imported"
OnlyQualifiedNS -> "only-qualified"
instance Pretty NameSpace where
pretty = vcat . prettyNameSpace
prettyNameSpace :: NameSpace -> [Doc]
prettyNameSpace (NameSpace names mods _) =
blockOfLines (text "names") (map pr $ Map.toList names) ++
blockOfLines (text "modules") (map pr $ Map.toList mods)
where
pr :: (Pretty a, Pretty b) => (a,b) -> Doc
pr (x, y) = pretty x <+> text "-->" <+> pretty y
instance Pretty Scope where
pretty (scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps }) =
vcat $
[ text "scope" <+> pretty name ] ++ ind (
concat [ blockOfLines (pretty nsid) $ prettyNameSpace $ scopeNameSpace nsid scope
| nsid <- [minBound..maxBound] ]
++ blockOfLines (text "imports")
(case Map.keys imps of [] -> []; ks -> [ prettyList ks ])
)
where ind = map $ nest 2
blockOfLines :: Doc -> [Doc] -> [Doc]
blockOfLines _ [] = []
blockOfLines hd ss = hd : map (nest 2) ss
instance Pretty ScopeInfo where
pretty (ScopeInfo this mods toBind locals ctx _ _ _) = vcat $
[ text "ScopeInfo"
, text " current = " <> pretty this
] ++
(if null toBind then [] else [ text " toBind = " <> pretty locals ]) ++
(if null locals then [] else [ text " locals = " <> pretty locals ]) ++
[ text " context = " <> pretty ctx
, text " modules"
] ++
map (nest 4) (List.filter (not . null) $ map pretty $ Map.elems mods)
instance KillRange ScopeInfo where
killRange m = m
instance HasRange AbstractName where
getRange = getRange . anameName
instance SetRange AbstractName where
setRange r x = x { anameName = setRange r $ anameName x }