{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
module Agda.Syntax.Scope.Base where
import Prelude hiding ( null )
import Control.Arrow (first, second)
import Control.Monad
import Data.Either (partitionEithers)
import Data.Function
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe
import qualified Data.Semigroup as Sgrp
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.Syntax.Concrete.Fixity 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.Maybe (filterMaybe)
import Agda.Utils.Null
import Agda.Utils.Pretty
import Agda.Utils.Singleton
import qualified Agda.Utils.Map as Map
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
deriving (Data, Eq, Bounded, Enum, Show)
allNameSpaces :: [NameSpaceId]
allNameSpaces = [minBound..maxBound]
type ScopeNameSpaces = [(NameSpaceId, NameSpace)]
localNameSpace :: Access -> NameSpaceId
localNameSpace PublicAccess = PublicNS
localNameSpace PrivateAccess{} = PrivateNS
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 :: NameMap
, _scopeInverseModule :: ModuleMap
, _scopeInScope :: InScopeSet
, _scopeFixities :: C.Fixities
, _scopePolarities :: C.Polarities
}
deriving (Data, Show)
type NameMap = Map A.QName (NonEmpty C.QName)
type ModuleMap = Map A.ModuleName [C.QName]
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 BindingSource
= LambdaBound
| PatternBound
| LetBound
deriving (Data, Show, Eq)
data LocalVar = LocalVar
{ localVar :: A.Name
, localBindingSource :: BindingSource
, 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) = "." <> pretty x
shadowLocal :: [AbstractName] -> LocalVar -> LocalVar
shadowLocal [] _ = __IMPOSSIBLE__
shadowLocal ys (LocalVar x b zs) = LocalVar x b (ys ++ zs)
patternToModuleBound :: LocalVar -> LocalVar
patternToModuleBound x
| localBindingSource x == PatternBound =
x { localBindingSource = LambdaBound }
| otherwise = x
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
scopeCurrent :: Lens' A.ModuleName ScopeInfo
scopeCurrent f s =
f (_scopeCurrent s) <&>
\x -> s { _scopeCurrent = x }
scopeModules :: Lens' (Map A.ModuleName Scope) ScopeInfo
scopeModules f s =
f (_scopeModules s) <&>
\x -> s { _scopeModules = x }
scopeVarsToBind :: Lens' LocalVars ScopeInfo
scopeVarsToBind f s =
f (_scopeVarsToBind s) <&>
\x -> s { _scopeVarsToBind = x }
scopeLocals :: Lens' LocalVars ScopeInfo
scopeLocals f s =
f (_scopeLocals s) <&>
\x -> s { _scopeLocals = x }
scopePrecedence :: Lens' PrecedenceStack ScopeInfo
scopePrecedence f s =
f (_scopePrecedence s) <&>
\x -> s { _scopePrecedence = x }
scopeInverseName :: Lens' NameMap ScopeInfo
scopeInverseName f s =
f (_scopeInverseName s) <&>
\x -> s { _scopeInverseName = x }
scopeInverseModule :: Lens' ModuleMap ScopeInfo
scopeInverseModule f s =
f (_scopeInverseModule s) <&>
\x -> s { _scopeInverseModule = x }
scopeInScope :: Lens' InScopeSet ScopeInfo
scopeInScope f s =
f (_scopeInScope s) <&>
\x -> s { _scopeInScope = x }
scopeFixities :: Lens' C.Fixities ScopeInfo
scopeFixities f s =
f (_scopeFixities s) <&>
\x -> s { _scopeFixities = x }
scopePolarities :: Lens' C.Polarities ScopeInfo
scopePolarities f s =
f (_scopePolarities s) <&>
\x -> s { _scopePolarities = x }
scopeFixitiesAndPolarities :: Lens' (C.Fixities, C.Polarities) ScopeInfo
scopeFixitiesAndPolarities f s =
f' (_scopeFixities s) (_scopePolarities s) <&>
\ (fixs, pols) -> s { _scopeFixities = fixs, _scopePolarities = pols }
where
f' !fixs !pols = f (fixs, pols)
updateVarsToBind :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateVarsToBind = over scopeVarsToBind
setVarsToBind :: LocalVars -> ScopeInfo -> ScopeInfo
setVarsToBind = set scopeVarsToBind
updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateScopeLocals = over scopeLocals
setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo
setScopeLocals = set scopeLocals
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 Ord 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 NameOrModule = NameNotModule | ModuleNotName
deriving (Data, Eq, Ord, Show, Enum, Bounded)
data KindOfName
= ConName
| FldName
| PatternSynName
| GeneralizeName
| DisallowedGeneralizeName
| MacroName
| QuotableName
| DataName
| RecName
| FunName
| AxiomName
| PrimName
| OtherDefName
deriving (Eq, Ord, Show, Data, Enum, Bounded)
isDefName :: KindOfName -> Bool
isDefName = (>= DataName)
data KindsOfNames
= AllKindsOfNames
| SomeKindsOfNames (Set KindOfName)
| ExceptKindsOfNames (Set KindOfName)
elemKindsOfNames :: KindOfName -> KindsOfNames -> Bool
elemKindsOfNames k = \case
AllKindsOfNames -> True
SomeKindsOfNames ks -> k `Set.member` ks
ExceptKindsOfNames ks -> k `Set.notMember` ks
allKindsOfNames :: KindsOfNames
allKindsOfNames = AllKindsOfNames
someKindsOfNames :: [KindOfName] -> KindsOfNames
someKindsOfNames = SomeKindsOfNames . Set.fromList
exceptKindsOfNames :: [KindOfName] -> KindsOfNames
exceptKindsOfNames = ExceptKindsOfNames . Set.fromList
data WhyInScope
= Defined
| Opened C.QName WhyInScope
| Applied C.QName WhyInScope
deriving (Data, Show)
data AbstractName = AbsName
{ anameName :: A.QName
, anameKind :: KindOfName
, anameLineage :: WhyInScope
, anameMetadata :: NameMetadata
}
deriving (Data, Show)
data NameMetadata = NoMetadata
| GeneralizedVarsMetadata (Map A.QName A.Name)
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
instance LensFixity AbstractName where
lensFixity = lensAnameName . lensFixity
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
, resolvedBindingSource :: BindingSource
}
|
DefinedName Access AbstractName
|
FieldName (NonEmpty AbstractName)
|
ConstructorName (NonEmpty AbstractName)
|
PatternSynResName (NonEmpty AbstractName)
|
UnknownName
deriving (Data, Show, Eq)
instance Pretty ResolvedName where
pretty = \case
VarName x _ -> "variable" <+> pretty x
DefinedName a x -> pretty a <+> pretty x
FieldName xs -> "field" <+> pretty xs
ConstructorName xs -> "constructor" <+> pretty xs
PatternSynResName x -> "pattern" <+> pretty x
UnknownName -> "<unknown name>"
mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a
mergeNames = Map.unionWith List.union
mergeNamesMany :: Eq a => [ThingsInScope a] -> ThingsInScope a
mergeNamesMany = Map.unionsWith 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 <- allNameSpaces ]
, 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
, _scopeFixities = Map.empty
, _scopePolarities = Map.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)
mapScopeNS :: NameSpaceId
-> (NamesInScope -> NamesInScope )
-> (ModulesInScope -> ModulesInScope)
-> (InScopeSet -> InScopeSet )
-> Scope -> Scope
mapScopeNS nsid fd fm fs = modifyNameSpace nsid $ mapNameSpace fd fm fs
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 = allANames $ nsNames ns }
allANames :: NamesInScope -> InScopeSet
allANames = Set.fromList . map anameName . concat . Map.elems
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 = mergeNamesMany . map (inNameSpace . snd) . scopeNameSpaces
allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access)
allNamesInScope' s =
mergeNamesMany [ map (, nameSpaceAccess nsId) <$> inNameSpace ns
| (nsId, ns) <- scopeNameSpaces s ]
exportedNamesInScope :: InScope a => Scope -> ThingsInScope a
exportedNamesInScope = namesInScope [PublicNS, ImportedNS]
namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a
namesInScope ids s =
mergeNamesMany [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ]
allThingsInScope :: Scope -> NameSpace
allThingsInScope s =
NameSpace { nsNames = allNamesInScope s
, nsModules = allNamesInScope s
, nsInScope = Set.unions $ map (nsInScope . snd) $ scopeNameSpaces s
}
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] 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
addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope
addNameToScope nsid x y =
mapScopeNS nsid
(Map.insertWith (flip List.union) x [y])
id
(Set.insert $ anameName y)
removeNameFromScope :: NameSpaceId -> C.Name -> Scope -> Scope
removeNameFromScope nsid x = mapScopeNS nsid (Map.delete x) id id
addModuleToScope :: NameSpaceId -> C.Name -> AbstractModule -> Scope -> Scope
addModuleToScope nsid x m = mapScopeNS nsid id addM id
where addM = Map.insertWith (flip List.union) x [m]
data UsingOrHiding
= UsingOnly [C.ImportedName]
| HidingOnly [C.ImportedName]
usingOrHiding :: C.ImportDirective -> UsingOrHiding
usingOrHiding i =
case (using i, hiding i) of
(UseEverything, ys) -> HidingOnly ys
(Using xs , []) -> UsingOnly xs
_ -> __IMPOSSIBLE__
applyImportDirective :: C.ImportDirective -> Scope -> Scope
applyImportDirective dir = fst . applyImportDirective_ dir
applyImportDirective_
:: C.ImportDirective
-> Scope
-> (Scope, (Set C.Name, Set C.Name))
applyImportDirective_ dir@(ImportDirective{ impRenaming }) s
| null dir = (s, (empty, empty))
| otherwise = (mergeScope sUse sRen, (nameClashes, moduleClashes))
where
sUse :: Scope
sUse = useOrHide (usingOrHiding dir) s
sRen :: Scope
sRen = rename impRenaming s
exportedNSs = [PublicNS, ImportedNS]
nameClashes :: Set C.Name
nameClashes = Map.keysSet rNames `Set.intersection` Map.keysSet uNames
where
uNames, rNames :: NamesInScope
uNames = namesInScope exportedNSs sUse
rNames = namesInScope exportedNSs sRen
moduleClashes :: Set C.Name
moduleClashes = Map.keysSet uModules `Set.intersection` Map.keysSet rModules
where
uModules, rModules :: ModulesInScope
uModules = namesInScope exportedNSs sUse
rModules = namesInScope exportedNSs sRen
useOrHide :: UsingOrHiding -> Scope -> Scope
useOrHide (UsingOnly xs) = filterNames Set.member xs
useOrHide (HidingOnly xs) = filterNames Set.notMember $ map renFrom impRenaming ++ xs
filterNames :: (C.Name -> Set C.Name -> Bool) -> [C.ImportedName] ->
Scope -> Scope
filterNames rel xs = filterScope (`rel` Set.fromList ds) (`rel` Set.fromList ms)
where
(ds, ms) = partitionEithers $ for xs $ \case
ImportedName x -> Left x
ImportedModule m -> Right m
rename :: [C.Renaming] -> Scope -> Scope
rename rho = mapScope_ (updateFxs .
Map.mapMaybeKeys (AssocList.apply drho))
(Map.mapMaybeKeys (AssocList.apply mrho))
id
where
(drho, mrho) = partitionEithers $ for rho $ \case
Renaming (ImportedName x) (ImportedName y) _fx _ -> Left (x, y)
Renaming (ImportedModule x) (ImportedModule y) _fx _ -> Right (x, y)
_ -> __IMPOSSIBLE__
fixities :: AssocList C.Name Fixity
fixities = (`mapMaybe` rho) $ \case
Renaming _ (ImportedName y) (Just fx) _ -> Just (y, fx)
_ -> Nothing
updateFxs :: NamesInScope -> NamesInScope
updateFxs m = foldl upd m fixities
where
upd m (y, fx) = Map.adjust (map $ set lensFixity fx) y m
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 =
mapScopeNS PrivateNS
(Map.mapMaybe rName)
(Map.mapMaybe rMod)
(Set.filter (not . (`isInModule` m)))
where
rName as = filterMaybe (not . null) $ filter (not . (`isInModule` m) . anameName) as
rMod as = filterMaybe (not . null) $ filter (not . (`isLtChildModuleOf` m) . amodName) as
disallowGeneralizedVars :: Scope -> Scope
disallowGeneralizedVars = mapScope_ ((fmap . map) disallow) id id
where
disallow a = a { anameKind = disallowGen (anameKind a) }
disallowGen GeneralizeName = DisallowedGeneralizeName
disallowGen k = k
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 $ scope ^. scopeModules
root = scope ^. scopeCurrent
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 $ scope ^. scopeModules
s0 = look $ scope ^. scopeCurrent
everythingInScopeQualified :: ScopeInfo -> NameSpace
everythingInScopeQualified scope =
allThingsInScope $ mergeScopes $
chase Set.empty scopes
where
s0 = look $ scope ^. scopeCurrent
scopes = s0 : map look (scopeParents s0)
look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules
lookP = restrictPrivate . look
chase seen [] = []
chase seen (s : ss)
| Set.member name seen = chase seen ss
| otherwise = s : chase (Set.insert name seen) (imports ++ submods ++ ss)
where
name = scopeName s
imports = map lookP $ Map.elems $ scopeImports s
submods = map (lookP . amodName) $ concat $ Map.elems $ allNamesInScope s
flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName]
flattenScope ms scope =
Map.unionWith (++)
(build ms allNamesInScope root)
imported
where
current = moduleScope $ scope ^. scopeCurrent
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 $ scope ^. scopeModules
concreteNamesInScope :: ScopeInfo -> Set C.QName
concreteNamesInScope scope =
Set.unions [ build allNamesInScope root, imported, locals ]
where
current = moduleScope $ scope ^. scopeCurrent
root = mergeScopes $ current : map moduleScope (scopeParents current)
locals = Set.fromList [ C.QName x | (x, _) <- scope ^. scopeLocals ]
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 $ scope ^. scopeModules
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 =
nubOn fst $
findName q root ++ maybeToList topImports ++ imports
where
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules
current :: Scope
current = moduleScope $ scope ^. scopeCurrent
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 $ scope ^. scopeModules
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 (scope ^. scopeInScope)
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 = maybe [] NonEmpty.toList $ Map.lookup x (scope ^. scopeInverseName)
findModule x = fromMaybe [] $ Map.lookup x (scope ^. scopeInverseModule)
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 = nsInScope $ everythingInScopeQualified scope
}
where
this = scope ^. scopeCurrent
current = this : scopeParents (moduleScope this)
scopes = [ (m, restrict m s) | (m, s) <- Map.toList (scope ^. scopeModules) ]
moduleScope :: A.ModuleName -> Scope
moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules
restrict m s | m `elem` current = s
| otherwise = restrictPrivate 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, singleton x)
moduleMap = Map.fromListWith (++) $ do
(m, s) <- scopes
(x, ms) <- Map.toList (allNamesInScope s)
q <- amodName <$> ms
return (q, singleton (m, x))
nameMap :: NameMap
nameMap = Map.fromListWith (Sgrp.<>) $ do
(m, s) <- scopes
(x, ms) <- Map.toList (allNamesInScope s)
q <- anameName <$> ms
if m `elem` current
then return (q, singleton (C.QName x))
else do
y <- findModule m
let z = C.qualify y x
guard $ not $ internalName z
return (q, singleton 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"
instance Pretty NameSpace where
pretty = vcat . prettyNameSpace
prettyNameSpace :: NameSpace -> [Doc]
prettyNameSpace (NameSpace names mods _) =
blockOfLines "names" (map pr $ Map.toList names) ++
blockOfLines "modules" (map pr $ Map.toList mods)
where
pr :: (Pretty a, Pretty b) => (a,b) -> Doc
pr (x, y) = pretty x <+> "-->" <+> pretty y
instance Pretty Scope where
pretty (scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps }) =
vcat $
[ "scope" <+> pretty name ] ++ ind (
concat [ blockOfLines (pretty nsid) $ prettyNameSpace ns
| (nsid, ns) <- scopeNameSpaces scope ]
++ blockOfLines "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 $
[ "ScopeInfo"
, " current = " <> pretty this
] ++
(if null toBind then [] else [ " toBind = " <> pretty locals ]) ++
(if null locals then [] else [ " locals = " <> pretty locals ]) ++
[ " context = " <> pretty ctx
, " 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 }